! (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 PARKIND1 ,ONLY : JPIM, JPRB 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 BUTTERFLY_ALG_MOD, ONLY : CLONE, PACK_BUTTERFLY_STRUCT USE BYTES_IO_MOD, ONLY : JPBYTES_IO_SUCCESS, BYTES_IO_CLOSE, BYTES_IO_OPEN, BYTES_IO_WRITE !**** *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 INTEGER(KIND=JPIM) :: IRBYTES,IIBYTES,JMLOC,IPRTRV,IMLOC,IM,ILA,ILS,IFILE,JSETV INTEGER(KIND=JPIM) :: IDGLU,ISIZE,IBYTES,IRET,IBUF(JPIBUFL),IDUM,JGL,II INTEGER(KIND=JPIM) :: IDGLU2 TYPE(CLONE) :: YLCLONE REAL(KIND=JPRB) ,ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) ,ALLOCATABLE :: IBUFA(:) ! ------------------------------------------------------------------ IRBYTES = 8 IIBYTES = 4 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 IF( S%LUSEFLT ) THEN IBUF(1:2) = TRANSFER('LEGPOLBF',IBUF(1:2)) ELSE IBUF(1:2) = TRANSFER('LEGPOL ',IBUF(1:2)) ENDIF IBUF(3) = R%NSMAX IBUF(4) = R%NDGNH CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,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*IIBYTES,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 IF( S%LUSEFLT .AND. ILA > S%ITHRESHOLD) THEN CALL PACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_A,YLCLONE) ISIZE = SIZE(YLCLONE%COMMSBUF) IBUF(:) = (/IDGLU,ILA,ISIZE,IDUM/) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IIBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF IBYTES = ISIZE*IRBYTES CALL BYTES_IO_WRITE(IFILE,YLCLONE%COMMSBUF,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(YLCLONE%COMMSBUF) ELSE ISIZE = IDGLU*ILA IBYTES = ISIZE*IRBYTES 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) ENDIF ! Symmetric IF( S%LUSEFLT .AND. ILS > S%ITHRESHOLD) THEN CALL PACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_S,YLCLONE) ISIZE = SIZE(YLCLONE%COMMSBUF) IBUF(:) = (/IDGLU,ILS,ISIZE,IDUM/) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IIBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF IBYTES = ISIZE*IRBYTES CALL BYTES_IO_WRITE(IFILE,YLCLONE%COMMSBUF,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(YLCLONE%COMMSBUF) ELSE ISIZE = IDGLU*ILS IBYTES = ISIZE*IRBYTES 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) ENDIF ENDDO ENDDO ! Lat-lon grid IF(S%LDLL) THEN IBUF(:) = TRANSFER('LATLON---BEG-BEG',IBUF(1:4)) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,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*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IIBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF ISIZE = 2*IDGLU*2 IBYTES = ISIZE*IRBYTES 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*IRBYTES 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*IIBYTES,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