! (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 USE TPM_GEN, ONLY: NERR, JP_LEGPOLY_VERSION 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 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 ! Size of header in 4-byte integers ! Layout: ! 1. 20 bytes: the string "ECTRANS_LEGPOL_START" indicating the start of the header ! 2. 4 bytes: byte-order-marker indicating endianness of this platform ! 3. 4 bytes: version of the polynomial file ! 4. 4 bytes: version of ecTrans as packed integer ! 5. 8 bytes: polynomial type (one of the strings "LEGPOLBF" or "LEGPOL ") ! 6. 4 bytes: spectral truncation ! 7. 4 bytes: number of northern latitudes ! 8. 4 bytes: size of real numbers in bytes ! 9. 8 bytes: total size of data section in bytes ! 10. 32 bytes: padding reserved in case of future use ! 11. 20 bytes: the string "ECTRANS_LEGPOL_FINAL" indicating the end of the header ! Total: 112 bytes INTEGER(KIND=JPIM), PARAMETER :: JPHEADER = 8 * 112 / STORAGE_SIZE(1_JPIM) INTEGER(KIND=JPIM) :: IRBYTES,IIBYTES,JMLOC,IPRTRV,IMLOC,IM,ILA,ILS INTEGER(KIND=JPIM) :: IDGLU,ISIZE,IBYTES,IRET,IFILE,JSETV,JGL,II,IDGLU2 INTEGER(KIND=JPIM),POINTER :: IBUF(:) INTEGER(KIND=JPIM), POINTER :: IHEADER(:) REAL(KIND=JPRBT) ,ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) ,POINTER :: IBUFA(:) CHARACTER(LEN=8) :: CLABEL CHARACTER(LEN=16) :: CLABEL_16 CHARACTER(LEN=20) :: CL_HEADER INTEGER(KIND=JPIM) :: IBYTE_ORDER_MARKER, IVERSION ! ------------------------------------------------------------------ IRBYTES = 8 IIBYTES = 4 IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_OPEN(IFILE,C%CLEGPOLFNAME,'R') ALLOCATE(IBUF(JPIBUFL)) ALLOCATE(IHEADER(JPHEADER)) ELSE NULLIFY(IBUF) NULLIFY(IHEADER) ENDIF IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IHEADER,JPHEADER*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPHEADER,IHEADER,ADVANCE=.TRUE.) ENDIF ! Check compatibility of polynomial file CL_HEADER = TRANSFER(IHEADER(1:5), CL_HEADER) IF (CL_HEADER /= 'ECTRANS_LEGPOL_START') THEN WRITE(NERR,*) 'READ_LEGPOL: MALFORMED START HEADER MARKER ', CL_HEADER CALL ABORT_TRANS('READ_LEGPOL: MALFORMED START HEADER MARKER') ENDIF IBYTE_ORDER_MARKER = IHEADER(6) IF (IBYTE_ORDER_MARKER /= INT(z'12345678', JPIM)) THEN WRITE(NERR,*) 'READ_LEGPOL: WRONG ENDIANNESS ' CALL ABORT_TRANS('READ_LEGPOL: WRONG ENDIANNESS') ENDIF IVERSION = IHEADER(7) IF (IVERSION /= JP_LEGPOLY_VERSION) THEN WRITE(NERR,*) 'READ_LEGPOL: WRONG POLYNOMIAL FILE VERSION ', IVERSION CALL ABORT_TRANS('READ_LEGPOL: WRONG POLYNOMIAL FILE VERSION') ENDIF CLABEL = TRANSFER(IHEADER(9:10),CLABEL) IF (CLABEL /= 'LEGPOL ') THEN WRITE(NERR,*) CLABEL CALL ABORT_TRANS('READ_LEGPOL:WRONG LABEL') ENDIF IF (IHEADER(11) /= R%NSMAX) CALL ABORT_TRANS('READ_LEGPOL:WRONG SPECTRAL TRUNCATION') IF (IHEADER(12) /= R%NDGNH) CALL ABORT_TRANS('READ_LEGPOL:WRONG NO OF GAUSSIAN LATITUDES') IRBYTES = IHEADER(13) IF (IRBYTES /= INT(STORAGE_SIZE(1.0_JPRB) / 8, JPIM)) THEN CALL ABORT_TRANS('READ_LEGPOL: precision mismatch between file and build') ENDIF CL_HEADER = TRANSFER(IHEADER(24:28), CL_HEADER) IF (CL_HEADER /= 'ECTRANS_LEGPOL_FINAL') THEN WRITE(NERR,*) 'READ_LEGPOL: MALFORMED FINAL HEADER MARKER ', CL_HEADER CALL ABORT_TRANS('READ_LEGPOL: MALFORMED FINAL HEADER MARKER') ENDIF IF (C%CIO_TYPE == 'file') DEALLOCATE(IHEADER) 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