write_legpol_mod.F90 Source File

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

!**** *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
REAL(KIND=JPRBT) ,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
IBUF(1:2) = TRANSFER('LEGPOL  ',IBUF(1:2))
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
    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)
! Symmetric
    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)
  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