!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE GDOUT(KULOUT,KLEV,KITER,CDETIKET,CDTYPV,KSTAMP) 1,2
#if defined (DOC)
*
***s/r GDOUT - Transfert of the content of COMGD0 on a RPN
* . standard file
*
*Author : P. Gauthier *ARMA/AES June 9, 1992
*Revision:
* P. Gauthier *ARMA/AES Oct. 22, 1993: control of postprocessing
* . through the comdeck COMPOST
* P. Gauthier *ARMA/AES May 25, 1993:
* . Transfer of specific humidity and surface
* . pressure on file (only if defined in the model
* . state.
* P. Koclas *CMC/CMDA February 1994
* . -ip3 now= KITER in call to fstecr.
* -Add arguments CDTYPV KSTAMP.
* -Replace comdeck "comtrl" by "compost"
* L. Fillion *ARMA/AES Nov 1994:
* Output height field in decameters.
* C. Charette *ARMA/AES Jan 96
* -Read RPN standard file parameters from 'compost'
* P. Gauthier *ARMA/AES Dec. 1996
* . -Add the variables relative (QR)and absolute (QQ)
* . vorticity, streamfunction (PP), velocity potential
* . (CC) and divergence (DD) in the possible choices for
* . output (these fields are computed within POSTPROC
* . and are transferred to GDOUT via the comdeck
* . "localpost.cdk". This mechanism will allow for the
* . computation of diagnostic quantities and their transfer
* . The control remains the same as before: through NPPCVAR
* . (total number of variables to write) and their names
* . in CPPCVAR(*) defined in COMPOST.
* S. Pellerin *ARMA/AES Sept 97.
* Introduction of Ozone and Passive tracer.
* S. Pellerin *ARMA/AES Oct 97
* -Introduction of NIP1s from COMGEM
* -Modification in subroutine parameters (arguments).
* -Output of total ozone O3 (DU)
* M Buehner July 98
* -Get rid of check on level for 2D fields, since this
* caused subroutine to return before writing any 3D fields
* listed after a 2D field
* -Moved IP1= statement inside variables loop
* L. Fillion *ARMA/AES 16 nov 98
* - Adapt GZ and ES diagnostic output
* C. Charette *ARMA/AES 26 nov 98
* - Adapt HU, VT diagnostic output
* L. Fillion *ARMA/AES 4 dec 98
* - Allow output of TTB,TTU,GZB,GZU,PSB,PSU
* J. Halle *CMDA/AES Oct 99
* -modifications for TG
* JM Belanger CMDA/SMC Oct 2000
* . 32 bits conversion
* C. Charette *ARMA/SMC - Sept 2004
* - Conversion to hybrid vertical coordinate
*
*Arguments
* i KULOUT : unit used for output
* i KITER : iteration number in the minimization process
* i KLEV : index of the level to be transferred
* i- CDPPTYP : type of post-processing
* .
* . 'STAT' Model state contained in COMSP
* . 'GRID' Grid-point fields contained in COMGD
* .
* . 'XMXG' Total analysis increment
* . (COMSP - COMSPG)
* . 'XMXK' Analysis increment with respect to
* . a given reference state kept on file
* . (Current model state is assumed to be in
* . COMSP)
* i CDETIKET: label used for identification in the RPN standard
* . file (exactly 8 characters, otherwise, it bombs)
* i CDTYPV : type of variable written in the RPN standard
* . file
* i KSTAMP : CMC DATESTAMP written to the RPN standard file
*
#endif
C
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "comcva.cdk"
#include "comgd0.cdk"
#include "compost.cdk"
*
INTEGER KLEV, KITER, KSTAMP
CHARACTER*8 CDETIKET
CHARACTER*1 CDTYPV
*
INTEGER VFSTECR, IERR, IPAK, KULOUT, IDATEO, JLON, JGL, JVAR
INTEGER IP2,IP3,IG1,IG2,IG3,IG4,IDATYP,INPAS,IDEET,IP1
REAL*8 ZTRANS(NI,NJ)
REAL*8 ZTEMP, ZGEOP, ZDAM, ZCON, un, dix
POINTER(PXTRANS,ZTRANS)
#include "localpost.cdk"
C
CHARACTER*1 CLGRTYP, CLTYPVAR
LOGICAL LLREWRIT, LLOK
EXTERNAL ABORT3D, VFSTECR, HPALLOC,HPDEALLC
C----------------------------------------------------------------
un=1.0D0
dix=1.0D1
CALL HPALLOC(PXTRANS,MAX(NI*NJ,1),IERR,8)
C
C* 1. Definition of the parameters for the RPN standard file
C . ------------------------------------------------------
C
100 CONTINUE
C
C*
C* Parameters obtained via argument list
C*
IDATEO =KSTAMP
IP3 =KITER
CLTYPVAR =CDTYPV
C
C*
C* Parameters obtained via (compost)
C*
CLGRTYP = CGRTYP
IP1 = NIP1(KLEV)
IP2 = NIP2
IDEET = NDEET
INPAS = NPAS
IG1 = NIG1
IG2 = NIG2
IG3 = NIG3
IG4 = NIG4
IDATYP = NIDATYP
IPAK = NPAK
C
C Overwrite record,if applicable, in standard file
LLREWRIT = .TRUE.
C
C 2. Transfer of the fields of COMGD to an internal buffer
C . -----------------------------------------------------
200 CONTINUE
C
WRITE(NULOUT,FMT='(/,4X,''Transfer of the gridpoint model'',
S '' state on file at iteration No.'',I3
S ,/,12X,''Level No.'',I4,4x,''VLEV'',E13.6)')
S KITER,KLEV,VLEV(KLEV)
C
c SET DIAGNOSTIC VARIABLES ON IF FIRST VAR IS PP (for GENINCR branch)
c
IF(CPPCVAR(1).EQ.'PP') LVARDIAG=.TRUE.
C
DO 201 JVAR = 1, NPPCVAR
LLOK = .TRUE.
write(NULOUT,*) JVAR,CPPCVAR(JVAR),NPPCVAR
IP1 =NIP1(KLEV)
C
C . 2.1 Fields associated with model variables
C
210 CONTINUE
C
IF(CPPCVAR(JVAR).EQ.'TT') THEN
C
C * Temperature field
C
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = TT0(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'TB') THEN
C
C * Balanced Temperature field
C
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZTTB(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'TU') THEN
C
C * Unbalanced Temperature field
C
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZTTU(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'UT') THEN
C
C * Unbalanced Temperature field for stat
C
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZTP(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'VT') THEN
C
C * Virtual temperature field
C
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZTV(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'GZ') THEN
C
C * Geopotential field
C
ZGEOP = dix * RG
ZDAM = un/ZGEOP
c
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZDAM * zgz(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'ZB') THEN
C
C * Balanced Geopotential field
C
ZGEOP = dix * RG
ZDAM = un/ZGEOP
c
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZDAM * zgzb(JLON,KLEV,JGL)
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'ZU') THEN
C
C * Unbalanced Geopotential field
C
ZGEOP = dix * RG
ZDAM = un/ZGEOP
c
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZDAM * zgzu(JLON,KLEV,JGL)
END DO
END DO
C
C * Zonal wind component (in Knots)
C
ELSE IF(CPPCVAR(JVAR).EQ.'UU') THEN
DO JGL = 1, NJ
DO JLON = 1, NI
ZTRANS(JLON,JGL) = UT0(JLON,KLEV,JGL)
S *CONPHY(JGL)*RKNTMS
END DO
END DO
C
C * Meridional wind component (in Knots)
C
ELSE IF(CPPCVAR(JVAR).EQ.'VV') THEN
DO JGL = 1, NJ
DO JLON = 1, NI
ZTRANS(JLON,JGL) = VT0(JLON,KLEV,JGL)
S *CONPHY(JGL)*RKNTMS
END DO
END DO
C
C * Humidity field
C
ELSE IF(CPPCVAR(JVAR).EQ.'ES') THEN
if(chum .eq. 'LQ') then
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = zes(JLON,KLEV,JGL)
END DO
END DO
elseif(chum .eq. 'ES') then
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = Q0(JLON,KLEV,JGL)
END DO
END DO
endif
C
ELSE IF(CPPCVAR(JVAR).EQ.'LQ') THEN
if(chum .eq. 'LQ') then
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = Q0(JLON,KLEV,JGL)
END DO
END DO
ELSEIF(CHUM .EQ. 'ES')THEN
LLOK = .FALSE.
WRITE(NULOUT,*)' ****************************************'
WRITE(NULOUT,'(" GDOUT: THE REQUESTED FIELD LQ IS NOT "
& ,"SUPPORTED WHEN CVCORD= ",A8," AND CHUM= ",A2)')
& CVCORD,CHUM
WRITE(NULOUT,*)' ****************************************'
ENDIF
ELSE IF(CPPCVAR(JVAR).EQ.'HU') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = zhu(JLON,KLEV,JGL)
END DO
END DO
C
C * Ozone field
C
ELSE IF(CPPCVAR(JVAR).EQ.'OZ') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = GOZ0(JLON,KLEV,JGL)
END DO
END DO
C
C * Passive Tracer field
C
ELSE IF(CPPCVAR(JVAR).EQ.'TR') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = GTR0(JLON,KLEV,JGL)
END DO
END DO
C
C * Surface Pressure from units of Pascal to millibar
C
ELSE IF(CPPCVAR(JVAR).EQ.'P0') THEN
IP1=0
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = GPS0(JLON,1,JGL)*RPATMB
END DO
END DO
C
C * Ground temperature in Kelvin
C
ELSE IF(CPPCVAR(JVAR).EQ.'TG') THEN
IP1=0
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = GTG0(JLON,1,JGL)
END DO
END DO
c
else if (LVARDIAG) then
C
C . 2.2 Diagnostic fields produced in DIAG3DVAR
C
220 CONTINUE
C
C Relative vorticity
C
IF(CPPCVAR(JVAR).EQ.'QR') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZQR(JLON,KLEV,JGL)
END DO
END DO
C
C Absolute vorticity
C
ELSE IF(CPPCVAR(JVAR).EQ.'QQ') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZQQ(JLON,KLEV,JGL)
END DO
END DO
C
C Divergence
C
ELSE IF(CPPCVAR(JVAR).EQ.'DD') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZDD(JLON,KLEV,JGL)
END DO
END DO
C
C Velocity potential
C
ELSE IF(CPPCVAR(JVAR).EQ.'CC') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZCC(JLON,KLEV,JGL)
END DO
END DO
C
C Unbalanced Velocity potential
C
ELSE IF(CPPCVAR(JVAR).EQ.'UC') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZUC(JLON,KLEV,JGL)
END DO
END DO
C
C Stream function
C
ELSE IF(CPPCVAR(JVAR).EQ.'PP') THEN
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZPP(JLON,KLEV,JGL)
END DO
END DO
C
C * 2.3 OTHER SURFACE FIELDS
C
C
230 CONTINUE
ELSE IF(CPPCVAR(JVAR).EQ.'PB') THEN
C
C Balanced surface-pressure
C
IP1=0
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = zpsb(JLON,JGL)*RPATMB
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'PU') THEN
C
C Unbalanced surface-pressure
C
IP1=0
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = zpsu(JLON,JGL)*RPATMB
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'UP') THEN
C
C Unbalanced surface-pressure for stat
C
IP1=0
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZLPP(JLON,1,JGL)*1.0D-2
END DO
END DO
ELSE IF(CPPCVAR(JVAR).EQ.'O3') THEN
IP1=0
DO JLON = 1, NI
DO JGL = 1, NJ
ZTRANS(JLON,JGL) = ZO3(JLON,JGL)
END DO
END DO
else
LLOK = .FALSE.
WRITE(NULOUT,*)' ****************************************'
WRITE(NULOUT,'(" GDOUT: THE DIAGNOSTIC FIELD IS NOT "
& ,"SUPPORTED CPPCVAR= ",A2)')CPPCVAR(JVAR)
WRITE(NULOUT,*)' ****************************************'
endif
else
LLOK = .FALSE.
WRITE(NULOUT,*)' ****************************************'
WRITE(NULOUT,'(" GDOUT: THE FOLLOWING FIELD IS NOT "
& ,"SUPPORTED CPPCVAR= ",A2)')CPPCVAR(JVAR)
WRITE(NULOUT,*)' ****************************************'
END IF
C
C* Write to the RPN standard file
C
300 CONTINUE
*
C* IF Output field is stored from South to North
C*
IF (LLOK) THEN
IF ( IG2 .EQ. 0 ) THEN
DO 262 JLON = 1, NI
DO 263 JGL = 1, NJ/2
ZTEMP=ZTRANS(JLON,JGL)
ZTRANS(JLON,JGL)=ZTRANS(JLON,NJ-JGL+1)
ZTRANS(JLON,NJ-JGL+1)=ZTEMP
263 CONTINUE
262 CONTINUE
ENDIF
C
IERR = VFSTECR(ZTRANS,ZTRANS,IPAK,KULOUT,IDATEO,IDEET,INPAS
$ ,NI,NJ,1,IP1,IP2,IP3,CLTYPVAR,CPPCVAR(JVAR),CDETIKET
S ,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,LLREWRIT)
ENDIF
C
201 CONTINUE
C
C* 9. Deallocation of local arrays (Abort on error)
C . ---------------------------------------------
C
900 CONTINUE
C
CALL HPDEALLC(PXTRANS,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'GDOUT. Problem with ZTRANS.')
END IF
C
RETURN
END