!-------------------------------------- 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 WRITEPTOT 1,6
#if defined (DOC)
*
***s/r WRITEPTOT -write the balance operators
*
*Author: M.Buehner 1998
*Revision: R. Sarrazin October 1998
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
* C. Charette - ARMA/SMC - Sep. 2004
* . Conversion to hybrid vertical coordinate
* Added fields 'HY' and 'LP' to output file
*
*Arguments: NONE
*
#endif
IMPLICIT NONE
*implicits
*
* Global variables
*
#include "pardim.cdk"
#include "comdim.cdk"
#include "comcorr.cdk"
#include "comcse1.cdk"
#include "comgem.cdk"
*
* Local variables
*
INTEGER IULPTOT
C
C * RPN Standard files parameters
C
INTEGER IERR, IPAK,jk
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, VFSTECR,write_encode_hyb
INTEGER IP1,IP2,IP3, IDATYP, IDATEO
real zptop4, zpref4,zrcoef4
real*8 zps,zlev(nflev)
C
EXTERNAL FNOM, FSTOUV, FSTFRM, FCLOS, VFSTECR, write_encode_hyb
C
cjmo modification temporaire pour valider le code stat avec v804a
INTEGER IM,JM,KM
cjmb do KM= 2, NJ
cjmb do JM = 1, NFLEV
cjmb do IM = 1, NFLEV+1
cjmb PTOT(IM,JM,KM)=PTOT(IM,JM,1)
cjmb enddo
cjmb enddo
cjmb enddo
cjmo fin modification temporaire
IULPTOT = 57
CALL READNML('NAMCSE1',IERR)
IERR = FNOM (IULPTOT,CFLPTOT,'RND+OLD',0)
IERR = FSTOUV(IULPTOT,'RND')
C
IPAK = -32
IDATYP = 5
IP1 = 0
IP2 = 0
IP3 = nensemble
IDATEO = ndatestat
C
C WRITES the hybrid coordinate parameters IN PTOT FILE
C
zptop4 = rptopinc
zpref4 = rprefinc
zrcoef4= rcoefinc
ierr = write_encode_hyb(IULPTOT,'HY',ip2,ip3,'PARAMS'
& ,IDATEO,zptop4,zpref4,zrcoef4)
C
C WRITES THE MODEL LEVELS IN PTOT FILE
C
IERR = VFSTECR(VLEV,VLEV,IPAK,IULPTOT
+ ,IDATEO,0,0,NFLEV,1,1
+ ,IP1,IP2,IP3,'X','LV','ETALEVLS','X'
+ ,0,0,0,0,IDATYP,.TRUE.)
C
C WRITES THE PRESSURE LEVELS IN PTOT FILE
C
zps = 101000.0D0
call calcpres(zlev,vlev,nflev,zps,rptopinc
& ,rprefinc,rcoefinc,1)
IERR = VFSTECR(ZLEV,ZLEV,IPAK,IULPTOT
+ ,IDATEO,0,0,NFLEV,1,1
+ ,IP1,IP2,IP3,'X','LP','ETALEVLS','X'
+ ,0,0,0,0,IDATYP,.TRUE.)
C
330 CONTINUE
cjmo modification temporaire pour valider le code stat avec v804a
c IERR = VFSTECR(PTOT(1,1,1),PTOT(1,1,1),IPAK,IULPTOT
c S ,IDATEO,0,0,NFLEV+1,NFLEV,1
c S ,IP1,IP2,IP3,'X','ZZ','P_to_T','X'
c S ,0,0,0,0,IDATYP,.TRUE.)
IERR = VFSTECR(PTOT(1,1,1),PTOT(1,1,1),IPAK,IULPTOT
S ,IDATEO,0,0,NFLEV+1,NFLEV,NJ
S ,IP1,IP2,IP3,'X','ZZ','P_to_T ','X'
S ,0,0,0,0,IDATYP,.TRUE.)
C
IERR = VFSTECR(THETA(1,1),THETA(1,1),IPAK,IULPTOT
S ,IDATEO,0,0,NFLEV,NJ,1
S ,IP1,IP2,IP3,'X','ZZ','THETA ','X'
S ,0,0,0,0,IDATYP,.TRUE.)
C
400 CONTINUE
IERR = FSTFRM(IULPTOT)
IERR = FCLOS (IULPTOT)
C
RETURN
END