! (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 PARKIND_ECTRANS ,ONLY : JPIM, JPRBT ,JPRD USE TPM_GEN USE TPM_DISTR USE TPM_DIM USE TPM_GEOMETRY USE TPM_FLT USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE TPM_CTL USE BYTES_IO_MOD USE SHAREDMEM_MOD !**** *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=JPRBT) ,ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) ,POINTER :: IBUFA(:) 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(CLABEL /= 'LEGPOL ') THEN WRITE(NERR,*) 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(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 ! Symmetric 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 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