read_legpol_mod.F90 Source File


This file depends on

sourcefile~~read_legpol_mod.f90~2~~EfferentGraph sourcefile~read_legpol_mod.f90~2 read_legpol_mod.F90 sourcefile~abort_trans_mod.f90 abort_trans_mod.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~abort_trans_mod.f90 sourcefile~butterfly_alg_mod.f90 butterfly_alg_mod.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~butterfly_alg_mod.f90 sourcefile~sharedmem_mod.f90 sharedmem_mod.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~sharedmem_mod.f90 sourcefile~tpm_ctl.f90 tpm_ctl.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~tpm_ctl.f90 sourcefile~tpm_dim.f90 tpm_dim.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~tpm_dim.f90 sourcefile~tpm_distr.f90 tpm_distr.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~tpm_distr.f90 sourcefile~tpm_flt.f90 tpm_flt.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~tpm_flt.f90 sourcefile~tpm_gen.f90 tpm_gen.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~tpm_gen.f90 sourcefile~tpm_geometry.f90 tpm_geometry.F90 sourcefile~read_legpol_mod.f90~2->sourcefile~tpm_geometry.f90 sourcefile~abort_trans_mod.f90->sourcefile~tpm_distr.f90 sourcefile~abort_trans_mod.f90->sourcefile~tpm_gen.f90 sourcefile~butterfly_alg_mod.f90->sourcefile~sharedmem_mod.f90 sourcefile~ectrans_blas_mod.f90 ectrans_blas_mod.F90 sourcefile~butterfly_alg_mod.f90->sourcefile~ectrans_blas_mod.f90 sourcefile~interpol_decomp_mod.f90 interpol_decomp_mod.F90 sourcefile~butterfly_alg_mod.f90->sourcefile~interpol_decomp_mod.f90 sourcefile~tpm_ctl.f90->sourcefile~sharedmem_mod.f90 sourcefile~parkind_ectrans.f90 parkind_ectrans.F90 sourcefile~tpm_flt.f90->sourcefile~parkind_ectrans.f90 sourcefile~seefmm_mix.f90 seefmm_mix.F90 sourcefile~tpm_flt.f90->sourcefile~seefmm_mix.f90 sourcefile~tpm_gen.f90->sourcefile~parkind_ectrans.f90 sourcefile~tpm_geometry.f90->sourcefile~parkind_ectrans.f90 sourcefile~seefmm_mix.f90->sourcefile~parkind_ectrans.f90 sourcefile~wts500_mod.f90 wts500_mod.F90 sourcefile~seefmm_mix.f90->sourcefile~wts500_mod.f90 sourcefile~wts500_mod.f90->sourcefile~parkind_ectrans.f90

Source Code

! (C) Copyright 2015- ECMWF.
! (C) Copyright 2015- Meteo-France.
! 
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
! In applying this licence, ECMWF does not waive the privileges and immunities
! granted to it by virtue of its status as an intergovernmental organisation
! nor does it submit to any jurisdiction.
!

MODULE READ_LEGPOL_MOD
CONTAINS
SUBROUTINE READ_LEGPOL
USE PARKIND1  ,ONLY : JPIM, JPRB ,JPRD
USE TPM_GEN, ONLY : NERR
USE TPM_DISTR, ONLY : D, NPRTRV
USE TPM_DIM, ONLY : R
USE TPM_GEOMETRY, ONLY : G
USE TPM_FLT, ONLY : S
USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS
USE TPM_CTL, ONLY : C
USE BYTES_IO_MOD, ONLY : BYTES_IO_READ, JPBYTES_IO_SUCCESS, BYTES_IO_CLOSE, BYTES_IO_OPEN
USE BUTTERFLY_ALG_MOD, ONLY : CLONE, UNPACK_BUTTERFLY_STRUCT
USE SHAREDMEM_MOD, ONLY : SHAREDMEM_ASSOCIATE

!**** *READ_LEGPOL * - read in Leg.Pol. and assocciated arrays from file or memory segment

!     Purpose.
!     --------
!           

!**   Interface.
!     ----------
!        *CALL* *READ_LEGPOL*

!        Explicit arguments : None
!        --------------------

!        Implicit arguments :
!        --------------------
!            

!     Method.
!     -------
!        See documentation

!     Externals.
!     ----------

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS
!     

!     -------
!        Mats Hamrud and Willem Deconinck  *ECMWF*

!     Modifications.
!     --------------
!        Original : July 2015

IMPLICIT NONE

INTEGER(KIND=JPIM),PARAMETER :: JPIBUFL=4
INTEGER(KIND=JPIM) :: IRBYTES,IIBYTES,JMLOC,IPRTRV,IMLOC,IM,ILA,ILS
INTEGER(KIND=JPIM) :: IDGLU,ISIZE,IBYTES,IRET,IFILE,JSETV,IDUM,JGL,II,IDGLU2
INTEGER(KIND=JPIM),POINTER :: IBUF(:)
REAL(KIND=JPRB) ,ALLOCATABLE :: ZBUF(:)
INTEGER(KIND=JPIM) ,POINTER :: IBUFA(:)
TYPE(CLONE) :: YLCLONE
CHARACTER(LEN=8) :: CLABEL
CHARACTER(LEN=16) :: CLABEL_16

!     ------------------------------------------------------------------

IRBYTES = 8
IIBYTES = 4
IDUM = 3141

IF(C%CIO_TYPE == 'file') THEN
  CALL BYTES_IO_OPEN(IFILE,C%CLEGPOLFNAME,'R')
  ALLOCATE(IBUF(JPIBUFL))
ELSE
  NULLIFY(IBUF)
ENDIF
IF(C%CIO_TYPE == 'file') THEN
  CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET)
ELSE
  CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.)
ENDIF
CLABEL = TRANSFER(IBUF(1:2),CLABEL)
IF( S%LUSEFLT .AND. CLABEL /= 'LEGPOLBF') THEN
  WRITE(NERR,*) S%LUSEFLT,CLABEL
  CALL ABORT_TRANS('READ_LEGPOL:WRONG LABEL')
ELSEIF(.NOT. S%LUSEFLT .AND. CLABEL /= 'LEGPOL  ') THEN
  WRITE(NERR,*) S%LUSEFLT,CLABEL
  CALL ABORT_TRANS('READ_LEGPOL:WRONG LABEL')
ENDIF
IF(IBUF(3) /= R%NSMAX) CALL ABORT_TRANS('READ_LEGPOL:WRONG SPECTRAL TRUNCATION')
IF(IBUF(4) /= R%NDGNH) CALL ABORT_TRANS('READ_LEGPOL:WRONG NO OF GAUSSIAN LATITUDES')
IF(C%CIO_TYPE == 'file') THEN
  ALLOCATE(IBUFA(2*R%NDGNH))
  CALL BYTES_IO_READ(IFILE,IBUFA,2*R%NDGNH*IIBYTES,IRET)
ELSE
  CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*R%NDGNH,IBUFA,ADVANCE=.TRUE.)
ENDIF
II = 0
DO JGL=1,R%NDGNH
  II = II+1
  IF(IBUFA(II) /= G%NLOEN(JGL)) THEN
    WRITE(NERR,*) 'WRONG NUMBER OF LONGITUDE POINTS ', JGL,G%NLOEN(JGL),IBUFA(II)
    CALL ABORT_TRANS('READ_LEGPOL:WRONG NLOEN')
  ENDIF
  II=II+1
  IF(IBUFA(II) /= G%NMEN(JGL)) THEN
    WRITE(NERR,*) 'WRONG CUT-OFF WAVE NUMBER ', JGL,G%NMEN(JGL),IBUFA(II)
    CALL ABORT_TRANS('READ_LEGPOL:WRONG NMEN')
  ENDIF
ENDDO
IF(C%CIO_TYPE == 'file') THEN
  DEALLOCATE(IBUFA)
ENDIF

DO JMLOC=1,D%NUMP,NPRTRV  ! +++++++++++++++++++++ JMLOC LOOP ++++++++++
  IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1)
  DO JSETV=1,IPRTRV
    IMLOC=JMLOC+JSETV-1
    IM = D%MYMS(IMLOC)
    ILA = (R%NSMAX-IM+2)/2
    ILS = (R%NSMAX-IM+3)/2
    IDGLU = MIN(R%NDGNH,G%NDGLU(IM))
! Anti-symmetric
    IF( S%LUSEFLT .AND. ILA > S%ITHRESHOLD) THEN
      IF(C%CIO_TYPE == 'file') THEN
        CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET)
      ELSE
        CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.)
      ENDIF
      IF(IBUF(1) /= IDGLU .OR. IBUF(2) /= ILA ) THEN
        WRITE(NERR,*) 'READ_LEGPOL ERROR ', IBUF,IDGLU,ILA
        CALL ABORT_TRANS('READ_LEGPOL:WRONG MATRIX SIZE')
      ENDIF

      ISIZE = IBUF(3)
      IF(C%CIO_TYPE == 'file') THEN
        ALLOCATE(YLCLONE%COMMSBUF(ISIZE))
        IBYTES = ISIZE*IRBYTES
        CALL BYTES_IO_READ(IFILE,YLCLONE%COMMSBUF,IBYTES,IRET)
        CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_A,YLCLONE)
        DEALLOCATE(YLCLONE%COMMSBUF)
      ELSE
        CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_A,YDMEMBUF=C%STORAGE)
      ENDIF
    ELSE
      IF(C%CIO_TYPE == 'file') THEN
        ISIZE = IDGLU*ILA
        ALLOCATE(ZBUF(ISIZE))
        IBYTES = ISIZE*IRBYTES
        CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET)
        IF(IRET < JPBYTES_IO_SUCCESS ) THEN
          WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET
          CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED')
        ENDIF
        ALLOCATE(S%FA(IMLOC)%RPNMA(IDGLU,ILA))
        S%FA(IMLOC)%RPNMA(:,:) = RESHAPE(ZBUF,(/IDGLU,ILA/))
        DEALLOCATE(ZBUF)
      ELSE
        CALL SHAREDMEM_ASSOCIATE(C%STORAGE,IDGLU,ILA,S%FA(IMLOC)%RPNMA,ADVANCE=.TRUE.)
      ENDIF
    ENDIF
! Symmetric
    IF( S%LUSEFLT .AND. ILS > S%ITHRESHOLD) THEN
      IF(C%CIO_TYPE == 'file') THEN
        CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET)
      ELSE
        CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.)
      ENDIF
      IF(IBUF(1) /= IDGLU .OR. IBUF(2) /= ILS ) THEN
        WRITE(NERR,*) 'READ_LEGPOL ERROR ', IBUF,IDGLU,ILA
        CALL ABORT_TRANS('READ_LEGPOL:WRONG MATRIX ZIZE')
      ENDIF
      ISIZE = IBUF(3)
      IF(C%CIO_TYPE == 'file') THEN
        ALLOCATE(YLCLONE%COMMSBUF(ISIZE))
        IBYTES = ISIZE*IRBYTES
        CALL BYTES_IO_READ(IFILE,YLCLONE%COMMSBUF,IBYTES,IRET)
        CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_S,YLCLONE)
        DEALLOCATE(YLCLONE%COMMSBUF)
      ELSE
        CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_S,YDMEMBUF=C%STORAGE)
      ENDIF
    ELSE
      IF(C%CIO_TYPE == 'file') THEN
        ISIZE = IDGLU*ILS
        IBYTES = ISIZE*IRBYTES
        ALLOCATE(ZBUF(ISIZE))
        CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET)
        IF(IRET < JPBYTES_IO_SUCCESS ) THEN
          WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET
          CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED')
        ENDIF
        ALLOCATE(S%FA(IMLOC)%RPNMS(IDGLU,ILS))
        S%FA(IMLOC)%RPNMS(:,:) = RESHAPE(ZBUF,(/IDGLU,ILS/))
        DEALLOCATE(ZBUF)
      ELSE
        CALL SHAREDMEM_ASSOCIATE(C%STORAGE,IDGLU,ILS,S%FA(IMLOC)%RPNMS,ADVANCE=.TRUE.)
      ENDIF
    ENDIF
  ENDDO
ENDDO

! Lat-lon grid
IF(S%LDLL) THEN
  IF(C%CIO_TYPE == 'file') THEN
    CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET)
  ELSE
    CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.)
  ENDIF
  CLABEL_16 = TRANSFER(IBUF,CLABEL_16)
  IF(CLABEL_16 /= 'LATLON---BEG-BEG')CALL ABORT_TRANS('READ_LEGPOL:WRONG LAT/LON LABEL')

   DO JMLOC=1,D%NUMP
    IM = D%MYMS(JMLOC)
    ILA = (R%NSMAX-IM+2)/2
    ILS = (R%NSMAX-IM+3)/2
    IDGLU = MIN(R%NDGNH,G%NDGLU(IM))
    IDGLU2 = S%NDGNHD

    IF(C%CIO_TYPE == 'file') THEN
      CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET)
    ELSE
      CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.)
    ENDIF
    IF(IBUF(1) /= IM .OR. IBUF(2) /= IDGLU  .OR. IBUF(3) /= IDGLU2 ) THEN
      WRITE(NERR,*) 'READ_LEGPOL ERROR ', IBUF,IM,IDGLU,IDGLU2
      CALL ABORT_TRANS('READ_LEGPOL:WRONG LAT-LON MATRIX SIZE')
    ENDIF

    IF(C%CIO_TYPE == 'file') THEN

      ISIZE = 2*IDGLU*2
      IBYTES = ISIZE*IRBYTES
      ALLOCATE(ZBUF(ISIZE))
      CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET)
      IF(IRET < JPBYTES_IO_SUCCESS ) THEN
        WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET
        CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED')
      ENDIF
      ALLOCATE(S%FA(JMLOC)%RPNMWI(2*IDGLU,2))
      S%FA(JMLOC)%RPNMWI(:,:) = RESHAPE(ZBUF,(/2*IDGLU,2/))
      DEALLOCATE(ZBUF)

      ISIZE = 2*IDGLU2*2
      IBYTES = ISIZE*IRBYTES
      ALLOCATE(ZBUF(ISIZE))
      CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET)
      IF(IRET < JPBYTES_IO_SUCCESS ) THEN
        WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET
        CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED')
      ENDIF
      ALLOCATE(S%FA(JMLOC)%RPNMWO(2*IDGLU2,2))
      S%FA(JMLOC)%RPNMWO(:,:) = RESHAPE(ZBUF,(/2*IDGLU2,2/))
      DEALLOCATE(ZBUF)

    ELSE
      CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*IDGLU,2,S%FA(JMLOC)%RPNMWI,ADVANCE=.TRUE.)
      CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*IDGLU2,2,S%FA(JMLOC)%RPNMWO,ADVANCE=.TRUE.)
    ENDIF
  ENDDO
ENDIF

IF(C%CIO_TYPE == 'file') THEN
  CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET)
ELSE
  CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.)
ENDIF
CLABEL_16 = TRANSFER(IBUF,CLABEL_16)
IF(CLABEL_16 /= 'LEGPOL---EOF-EOF')CALL ABORT_TRANS('READ_LEGPOL:WRONG END LABEL')
IF(C%CIO_TYPE == 'file') THEN
  CALL BYTES_IO_CLOSE(IFILE)
  DEALLOCATE(IBUF)
ENDIF

END SUBROUTINE READ_LEGPOL
END MODULE READ_LEGPOL_MOD