! (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 WRITE_LEGPOL_MOD CONTAINS SUBROUTINE WRITE_LEGPOL USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB 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: JPBYTES_IO_SUCCESS, BYTES_IO_CLOSE, BYTES_IO_OPEN, BYTES_IO_WRITE USE ECTRANS_VERSION_MOD, ONLY: ECTRANS_VERSION_INT USE TPM_GEN, ONLY: JP_LEGPOLY_VERSION !**** *WRITE_LEGPOL * - write out Leg.Pol. and assocciated arrays to file ! Purpose. ! -------- ! !** Interface. ! ---------- ! *CALL* *WRITE_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) ! Size of integer in bytes INTEGER(KIND=JPIM), PARAMETER :: JPIBYTES = 4 ! Size of real in bytes INTEGER(KIND=JPIM), PARAMETER :: JPRBYTES = INT(STORAGE_SIZE(1.0_JPRBT) / 8, JPIM) INTEGER(KIND=JPIM) :: JMLOC,IPRTRV,IMLOC,IM,ILA,ILS,IFILE,JSETV INTEGER(KIND=JPIM) :: IDGLU,ISIZE,IBYTES,IRET,IBUF(JPIBUFL),IHEADER(JPHEADER),IDUM,JGL,II INTEGER(KIND=JPIM) :: IDGLU2 REAL(KIND=JPRBT) ,ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) ,ALLOCATABLE :: IBUFA(:) INTEGER(KIND=JPIB) :: IBYTES_TO_WRITE ! ------------------------------------------------------------------ IDUM = 3141 IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_OPEN(IFILE,C%CLEGPOLFNAME,'W',IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_OPEN FAILED') ENDIF ! Determine total number of bytes to write in the data section IBYTES_TO_WRITE = 0 DO JMLOC = 1, D%NUMP, NPRTRV 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)) IBYTES_TO_WRITE = IBYTES_TO_WRITE + IDGLU * ILA * JPRBYTES IBYTES_TO_WRITE = IBYTES_TO_WRITE + IDGLU * ILS * JPRBYTES ENDDO ENDDO IF (S%LDLL) THEN IBYTES_TO_WRITE = IBYTES_TO_WRITE + JPIBUFL * JPIBYTES DO JMLOC=1,D%NUMP IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IDGLU2 = S%NDGNHD IBYTES_TO_WRITE = IBYTES_TO_WRITE + JPIBUFL * JPIBYTES IBYTES_TO_WRITE = IBYTES_TO_WRITE + 4 * IDGLU * JPRBYTES + 4 * IDGLU2 * JPRBYTES ENDDO ENDIF IBYTES_TO_WRITE = IBYTES_TO_WRITE + 2 * R%NDGNH * JPIBYTES ! Prepare header IHEADER(1:5) = TRANSFER('ECTRANS_LEGPOL_START', IHEADER(1:5)) IHEADER(6) = INT(z'12345678', JPIM) ! Byte-order-marker IHEADER(7) = JP_LEGPOLY_VERSION ! Version of the polynomial file IHEADER(8) = ECTRANS_VERSION_INT() IHEADER(9:10) = TRANSFER('LEGPOL ',IHEADER(9:10)) IHEADER(11) = R%NSMAX IHEADER(12) = R%NDGNH IHEADER(13) = JPRBYTES IHEADER(14:15) = TRANSFER(IBYTES_TO_WRITE, IHEADER(14:15)) IHEADER(16:23) = 0 ! Unused for now IHEADER(24:28) = TRANSFER('ECTRANS_LEGPOL_FINAL', IHEADER(24:28)) CALL BYTES_IO_WRITE(IFILE,IHEADER,JPHEADER*JPIBYTES,IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_WRITE FAILED') ALLOCATE(IBUFA(2*R%NDGNH)) II = 0 DO JGL=1,R%NDGNH II = II+1 IBUFA(II) = G%NLOEN(JGL) II=II+1 IBUFA(II) = G%NMEN(JGL) ENDDO CALL BYTES_IO_WRITE(IFILE,IBUFA,2*R%NDGNH*JPIBYTES,IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_WRITE FAILED') DEALLOCATE(IBUFA) 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 ISIZE = IDGLU*ILA IBYTES = ISIZE*JPRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(IMLOC)%RPNMA,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ! Symmetric ISIZE = IDGLU*ILS IBYTES = ISIZE*JPRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(IMLOC)%RPNMS,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ENDDO ENDDO ! Lat-lon grid IF(S%LDLL) THEN IBUF(:) = TRANSFER('LATLON---BEG-BEG',IBUF(1:4)) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*JPIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF 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 IBUF(:) = (/IM,IDGLU,IDGLU2,IDUM/) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*JPIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',JPIBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF ISIZE = 2*IDGLU*2 IBYTES = ISIZE*JPRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(JMLOC)%RPNMWI,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ISIZE = 2*IDGLU2*2 IBYTES = ISIZE*JPRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(JMLOC)%RPNMWO,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ENDDO ENDIF !End marker IBUF(:) = TRANSFER('LEGPOL---EOF-EOF',IBUF(1:4)) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*JPIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_CLOSE(IFILE,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_CLOSE FAILED') ENDIF ENDIF END SUBROUTINE WRITE_LEGPOL END MODULE WRITE_LEGPOL_MOD