! (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