!-------------------------------------- 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 ONEOBS 2,40
use mod4dv
, only : l4dvar
#if defined (DOC)
*
***s/r ONEOBS - Calculate a normalized column of B directly for comparison
* with results from single obs experiment
*
*Author : Mark Buehner, October 1998
*Revision:
* C.Charette ARMA/AES NOV 1998
* - DOCTOR standards for local variables. Adapt to new names
* for variables related to oneobs experiments in comcse1.cdk
* C.Charette ARMA/AES MAR 1999
* - Write increments in pressure and eta coordinates
* C.Charette ARMA/AES NOV 1999
* - Proper date stamp to pass to fstecr
* S. Pelleirn *ARMA/SMC may 2000
* -Logical unit cleanup
* JM Belanger CMDA/SMC Sep 2000
* . 32 bits conversion
* M. Buehner ARMA/MSC Jun 2002
* Adapted to run with v9.2.0
* M. Buehner ARMA/MSC Jan 2003
* Adapted to use B-matrix enhanced with SV's
* Adapted to calculate 1obs with 4d-var
* Y. Yang UofT Apr. 2004 (revised by Yves Rochon ARQX/MSC Aug. 2004)
* 1. Ps perturbation is set to zero for observations other than UU, VV,
* TT and GZ, to avoid undesired dependance. This is consistent with
* the normal 3dvar.
* 2. Input perturbation is no longer assumed to be at a particular
* model level, rather it is at the observation level. The increment
* is distributed to the two nearest model levels through adjoint of
* the vertical interpolation.
* C.Charette ARMA/AES SEP 2004
* - Added option to move observation to nearest analysis level via
* namelist (see LVLNEAR)
* -------------------
** Purpose: Project Background statistics into observation space
* .
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comcst.cdk"
#include "comct0.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "comgem.cdk"
#include "comcva.cdk"
#include "com1obs.cdk"
#include "comgd0.cdk"
#include "comstate.cdk"
#include "rpnstd.cdk"
#include "compost.cdk"
#include "comphy.cdk"
#include "comleg.cdk"
#include "comsv.cdk"
*
C
INTEGER IDATA,JLAT,JLON,ILEV,JK,IULSSF,JLA
INTEGER ILAT,ILON,ILEV1,ILEV2
REAL*8 ZTRANSE(NI,NJ),ZTRANSP(NI,NJ),ZNORMB,ZSIGOBS,Z1OBSLV
REAL*8 ZGRAD,ZP1,ZP2,ZDADPS2,ZPRESS,zpresbpb,zpresbpt, ZSCALE
REAL*8 ZWT, ZWB
POINTER(PXTRANSE,ZTRANSE),(PXTRANSP,ZTRANSP)
REAL*8 DVPS
ccc integer vfstecr
ccc external vfstecr
*-------------------------------------------------------------------
C
ZSCALE=1.0d-5
WRITE(NULOUT,FMT='(/,4X,"Starting ONEOBS",//)')
write(nulout,*) 'oneobs: before nobtot=',nobtot
NOBTOT=NJ*NI
write(nulout,*) 'oneobs: after nobtot=',nobtot
call suscal('I')
c
c Specify the background field and set all related variables
c
call su1obsbg
c
c Determine the nearest gridpoint of single obs
c
ILON=NI1OBSLO
ILAT=NI1OBSLA
IDATA = ((ILON-1)*NJ)+ILAT
write(NULOUT,*) 'oneobs:idata,ilat,ilon,nobtot'
& ,idata,ilat,ilon,nobtot
do jk=1,NFLEV
write(NULOUT,*) 'oneobs:jk, rppobs(*,idata)='
& ,jk,rppobs(jk,idata)
enddo
do jk=1,NKGDIMO
write(NULOUT,*) 'oneobs:jk,gomobsg(*,idata)='
& ,jk,gomobsg(jk,idata)
enddo
c
IULSSF=0
C
C* 0. Memory allocation
C
CALL HPALLOC(PXTRANSE,MAX(NI*NJ,1),IERR,8)
CALL HPALLOC(PXTRANSP,MAX(NI*NJ,1),IERR,8)
c
ZSIGOBS=R1OBSOER
if(C1OBSTP.eq.'GZ') ZSIGOBS=R1OBSOER*RG
c
c Set vertical Level (for direct computation)
c
Z1OBSLV=R1OBSLV*100
ilev1=1
ilev2=2
do jk=2,NFLEV-1
if(Z1OBSLV.gt.RPPOBS(jk,IDATA)) then
ilev1=jk
ilev2=jk+1
endif
enddo
if(abs(log(Z1OBSLV)-log(RPPOBS(ilev1,IDATA))).lt.
+ abs(log(Z1OBSLV)-log(RPPOBS(ilev2,IDATA)))) then
NI1OBSLV=ilev1
else
NI1OBSLV=ilev2
endif
write(NULOUT,*) 'ONEOBS:NI1OBS= ',NI1OBSLA,NI1OBSLO,NI1OBSLV
ILEV=NI1OBSLV
IF(LVLNEAR) THEN
write(NULOUT,*) 'ONEOBS:OBSERVATION MOVED TO NEAREST'
& ,' VERTICAL LEVEL LVLNEAR= ',LVLNEAR
Z1OBSLV = RPPOBS(ILEV,IDATA)
ILEV1 = MAX(ILEV-1,1)
ILEV2 = MAX(ILEV,2)
write(NULOUT,*) 'ONEOBS:level specified= ',R1OBSLV*100
& ,' nearest level= ', Z1OBSLV
ELSE
write(NULOUT,*) 'ONEOBS:OBSERVATION ASSIMILATED AT ITS'
& ,' SPECIFIED LEVEL LVLNEAR= ',LVLNEAR,' level= ',Z1OBSLV
& ,' PA'
ENDIF
write(NULOUT,*)
& 'ONEOBS:Z1OBSLV,ilev1,ilev2,RPPOBS(ilev1),,RPPOBS(ilev2)'
& ,Z1OBSLV,ilev1,ilev2,RPPOBS(ilev1,IDATA),RPPOBS(ilev2,IDATA)
write(NULOUT,*) 'ONEOBS:IDATA,ILON,ILAT,ILEV,TP='
+ ,IDATA,ILON,ILAT,ILEV,' ',C1OBSTP
C
c 1.0 Set desired element to 1.0 others to 0.0
c
CALL TRANSFER('ZOB0')
CALL TRANSFER('ZOB1')
CALL TRANSFER('ZGD0')
CALL TRANSFER('ZSP0')
c
C 1.1 Do adjoint of vertical interpolation (GOMOBS -> SP)
c
IF(C1OBSTP.ne.'P0') then
ZP1 = RPPOBS(ILEV1,IDATA)
ZP2 = RPPOBS(ILEV2,IDATA)
ZWB = LOG(Z1OBSLV/ZP1)/LOG(ZP2/ZP1)
ZWT = 1. - ZWB
ENDIF
C
zgrad=0.0
if(C1OBSTP.eq.'LQ'.and.NMVOEXIST(noq).eq.1) then
GOMQ(ILEV2,IDATA) = GOMQ(ILEV2,IDATA) + ZWB* R1OBSINO
GOMQ(ILEV1,IDATA) = GOMQ(ILEV1,IDATA) + ZWT* R1OBSINO
IF(ILEV.gt.1)
+ zgrad= 0.0
elseif(C1OBSTP.eq.'TT'.and.NMVOEXIST(nott).eq.1) then
GOMT(ILEV2,IDATA) = GOMT(ILEV2,IDATA) + ZWB* R1OBSINO
GOMT(ILEV1,IDATA) = GOMT(ILEV1,IDATA) + ZWT* R1OBSINO
IF(ILEV.gt.1)
+ zgrad=GOMTG(ILEV,IDATA)-GOMTG(ILEV-1,IDATA)
elseif(C1OBSTP.eq.'VV'.and.NMVOEXIST(novv).eq.1) then
GOMV(ILEV2,IDATA) = GOMV(ILEV2,IDATA) + ZWB* R1OBSINO
GOMV(ILEV1,IDATA) = GOMV(ILEV1,IDATA) + ZWT* R1OBSINO
IF(ILEV.gt.1)
+ zgrad=GOMVG(ILEV,IDATA)-GOMVG(ILEV-1,IDATA)
elseif(C1OBSTP.eq.'UU'.and.NMVOEXIST(nouu).eq.1) then
GOMU(ILEV2,IDATA) = GOMU(ILEV2,IDATA) + ZWB* R1OBSINO
GOMU(ILEV1,IDATA) = GOMU(ILEV1,IDATA) + ZWT* R1OBSINO
IF(ILEV.gt.1)
+ zgrad=GOMUG(ILEV,IDATA)-GOMUG(ILEV-1,IDATA)
***************************************************************
write(nulout,*)'oneobs:C1OBSTP,IDATA,LEV,vlev(LEV),R1OBSINO= '
& ,C1OBSTP,IDATA,ILEV,vlev(ILEV),R1OBSINO
write(nulout,*)'oneobs: zgrad,GOMUG(ILEV,),GOMUG(ILEV-1,) '
& ,GOMUG(ILEV,IDATA),GOMUG(ILEV-1,IDATA)
***************************************************************
elseif(C1OBSTP.eq.'GZ'.and.NMVOEXIST(nogz).eq.1) then
GOMGZ(ILEV2,IDATA) = GOMGZ(ILEV2,IDATA) + ZWB* R1OBSINO
GOMGZ(ILEV1,IDATA) = GOMGZ(ILEV1,IDATA) + ZWT* R1OBSINO
IF(ILEV.gt.1)
+ zgrad=GOMGZG(ILEV,IDATA)-GOMGZG(ILEV-1,IDATA)
***************************************************************
write(nulout,*)'oneobs:C1OBSTP,IDATA,LEV,vlev(LEV),R1OBSINO= '
& ,C1OBSTP,IDATA,ILEV,vlev(ILEV),R1OBSINO
IF(ILEV.gt.1) THEN
write(nulout,*)'oneobs: zgrad,GOMGZG(ILEV,),GOMGZG(ILEV-1,) '
& ,GOMGZG(ILEV,IDATA),GOMGZG(ILEV-1,IDATA)
ENDIF
***************************************************************
elseif(C1OBSTP.eq.'ES'.and.NMVOEXIST(noes).eq.1) then
GOMES(ILEV2,IDATA) = GOMES(ILEV2,IDATA) + ZWB* R1OBSINO
GOMES(ILEV1,IDATA) = GOMES(ILEV1,IDATA) + ZWT* R1OBSINO
IF(ILEV.gt.1)
+ zgrad=0.0
elseif(C1OBSTP.eq.'P0'.and.NMVOEXIST(nops).eq.1) then
GOMPS(1,IDATA) = R1OBSINO
endif
c
IF(ILEV.GT.1.AND.C1OBSTP.ne.'P0') then
ZP1 = RPPOBS(ILEV1,IDATA)
ZP2 = RPPOBS(ILEV2,IDATA)
zpresbpt = ((vhybinc(ILEV1) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
zpresbpb = ((vhybinc(ILEV2) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS2 = ( (ZPRESBPT/ZP1)*LOG(Z1OBSLV/ZP2)
+ -(ZPRESBPB/ZP2)*LOG(Z1OBSLV/ZP1) )
+ /LOG(ZP2/ZP1)**2
GOMPS(1,IDATA) = zgrad*ZDADPS2*R1OBSINO
***************************************************************
write(nulout,*)'oneobs: IDATA,ILEV,zp1,zp2,zwt,zwb,vlev(ILEV)= '
& ,IDATA,ILEV,zp1,zp2,zwt,zwb,vlev(ILEV)
write(nulout,*)'oneobs: C1OBSTP,R1OBSINO,ZDADPS2,zgrad,gomps= '
& ,C1OBSTP,R1OBSINO,ZDADPS2,ZGRAD,GOMPS(1,IDATA)
***************************************************************
ENDIF
c
CALL APREOBS
CALL GDTOMVOAD
if(l4dvar.and.NSVMODE.eq.0) then
DO JK = 1, NKGDIM
DO JLAT = 1, NJ
DO JLON = 1, NI
GD(JLON,JK,JLAT) = GD(JLON,JK,JLAT) * ZSCALE *
+ RWT(JLAT)/NILON(JLAT)
ENDDO
ENDDO
ENDDO
call putdx('A')
call getdx('A')
endif
IF(NSVMODE.gt.0) CALL SPA2SPADSV
if(nanalvar.eq.4) then
CALL SPA2GDAD
else
CALL SPGDA
CALL SPA2SPAD
endif
c
c 1.2 Now forward models (SP -> GOMOBS)
c
DO JK=1,NVADIM
VAZX(JK)=0.0
ENDDO
call cainad(NVADIM,VAZX)
call cain(NVADIM,VAZX)
c
if(nanalvar.eq.4) then
CALL SPA2GD
else
CALL SPA2SP
call SPGD
endif
if(l4dvar.and.NSVMODE.eq.0) then
nsim3d=nsim3d+1
call putdx('F')
call getdx('F')
call endsim
DO JK = 1, NKGDIM
DO JLAT = 1, NJ
DO JLON = 1, NI
GD(JLON,JK,JLAT) = GD(JLON,JK,JLAT) / ZSCALE
ENDDO
ENDDO
ENDDO
endif
IF(NSVMODE.gt.0) CALL SPA2SPSV
CALL GDTOMVO
CALL LPREOBS
c
C* Following added by Y. Yang
C
c Do equivalent of vertical ineterpolation
C to interpolate from the model levels to observation level
C
IF(C1OBSTP.ne.'P0') then
ZP1 = RPPOBS(ILEV1,IDATA)
ZP2 = RPPOBS(ILEV2,IDATA)
ZWB = LOG(Z1OBSLV/ZP1)/LOG(ZP2/ZP1)
ZWT = 1. - ZWB
dvps=0.0
if (ILEV.GT.1) then
zpresbpt = ((vhybinc(ILEV1) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
zpresbpb = ((vhybinc(ILEV2) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS2 = ( (ZPRESBPT/ZP1)*LOG(Z1OBSLV/ZP2)
+ -(ZPRESBPB/ZP2)*LOG(Z1OBSLV/ZP1) )
+ /LOG(ZP2/ZP1)**2
dvps= zgrad*ZDADPS2*GOMPS(1,IDATA)
endif
C Interpolate to the observation level
C
***************************************************************
write(nulout,*)'oneobs: IDATA,ILEV,zp1,zp2,vlev(ILEV)= '
& ,IDATA,ILEV,zp1,zp2,vlev(ILEV)
write(nulout,*)'oneobs: C1OBSTP,R1OBSINO,ZDADPS2,zgrad,gomps= '
& ,C1OBSTP,R1OBSINO,ZDADPS2,ZGRAD,GOMPS(1,IDATA)
***************************************************************
if(C1OBSTP.eq.'LQ'.and.NMVOEXIST(noq).eq.1) then
ZNORMB = ZWB*GOMQ(ILEV2,IDATA) + ZWT*GOMQ(ILEV1,IDATA)+dvps
elseif(C1OBSTP.eq.'TT'.and.NMVOEXIST(nott).eq.1) then
ZNORMB = ZWB*GOMT(ILEV2,IDATA) + ZWT*GOMT(ILEV1,IDATA)+dvps
elseif(C1OBSTP.eq.'VV'.and.NMVOEXIST(novv).eq.1) then
ZNORMB = ZWB*GOMV(ILEV2,IDATA) + ZWT*GOMV(ILEV1,IDATA)+dvps
elseif(C1OBSTP.eq.'UU'.and.NMVOEXIST(nouu).eq.1) then
ZNORMB = ZWB*GOMU(ILEV2,IDATA) + ZWT*GOMU(ILEV1,IDATA)+dvps
elseif(C1OBSTP.eq.'GZ'.and.NMVOEXIST(nogz).eq.1) then
ZNORMB = ZWB*GOMGZ(ILEV2,IDATA)+ZWT*GOMGZ(ILEV1,IDATA)+dvps
elseif(C1OBSTP.eq.'ES'.and.NMVOEXIST(noes).eq.1) then
ZNORMB = ZWB*GOMES(ILEV2,IDATA)+ZWT*GOMES(ILEV1,IDATA)+dvps
endif
ENDIF
C
if(C1OBSTP.eq.'P0') then
ZNORMB=GOMPS(1,IDATA)
endif
write(nulout,*) 'oneobs: output HBH^T = ',ZNORMB
c
c Grab var_b=HBH^T for the single obs, which is ZNORMB,
C for normalizing the column of B
c
ZNORMB=ZNORMB/R1OBSINO
write(NULOUT,*) 'EFFECTIVE BACKGROUND VARIANCE=',ZNORMB
ZNORMB=ZNORMB+(zsigobs**2)
write(NULOUT,*) 'final EFFECTIVE BACKGROUND VARIANCE=',ZNORMB
c
c *****************************************************
c OUTPUT T PROFILE AT OBS LOCATION FOR PIERRE
c
c do jk=1,NFLEV
c write(69,*) jk,GOMT(jk,IDATA)
c enddo
c *****************************************************
c
c 2. Write out 3D fields to file (in MKS units)
c
C Do not store pressure level - instead store eta.
C
IERR = FNOM(IULSSF,'inc1obs.fst','RND',0)
IERR = FSTOUV(IULSSF,'RND')
c
C
CCC Define a valid date stamp to satisfy fstecr
C YYYYMMDD HHMMSShh
CALL NEWDATE(IDATEO,19991125,12000000,3)
C
IDEET = 0
INPAS = 0
INK = 1
INJ = NJ
INI = NI
IP2 = 0
IP3 = 0
C
C Parameters obtained via (compost)
C
CLGRTYP = CGRTYP
IG1 = NIG1
IG2 = NIG2
IG3 = NIG3
IG4 = NIG4
IDATYP = NIDATYP
IPAK = NPAK
C
CLTYPVAR = 'R'
C
CLNOMVAR = 'LQ'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMQ(JK,IDATA)/ZNORMB
ZTRANSP(JLON,NJ-JLAT+1) = GOMQ(JK,IDATA)/ZNORMB
C-----------Compute LQ on P levels
IF(JK.gt.1) then
zgrad=GOMQG(JK,IDATA)-GOMQG(JK-1,IDATA)
ZP1 = RPPOBS(JK-1,IDATA)
ZP2 = RPPOBS(JK,IDATA)
zpresbpb = ((vhybinc(jk) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS2 = -(ZPRESBPB/ZP2)*LOG(ZP2/ZP1)
zpress= GOMQ(JK,IDATA) +
+ zgrad*ZDADPS2*GOMPS(1,IDATA)
ZTRANSP(JLON,NJ-JLAT+1)= zpress/ZNORMB
ENDIF
END DO
END DO
C
CLETIKET = '1OBSETA'
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c CLETIKET = '1OBSPRES'
c IERR = VFSTECR(ZTRANSP,ZTRANSP,IPAK,IULSSF,IDATEO
c S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
c S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
c
CLNOMVAR = 'ES'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMES(JK,IDATA)/ZNORMB
ZTRANSP(JLON,NJ-JLAT+1) = GOMES(JK,IDATA)/ZNORMB
C-----------Compute ES on P levels
IF(JK.gt.1) then
zgrad=GOMESG(JK,IDATA)-GOMESG(JK-1,IDATA)
ZP1 = RPPOBS(JK-1,IDATA)
ZP2 = RPPOBS(JK,IDATA)
zpresbpb = ((vhybinc(jk) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS2 = -(ZPRESBPB/ZP2)*LOG(ZP2/ZP1)
zpress= GOMES(JK,IDATA) +
+ zgrad*ZDADPS2*GOMPS(1,IDATA)
ZTRANSP(JLON,NJ-JLAT+1)= zpress/ZNORMB
ENDIF
END DO
END DO
C
CLETIKET = '1OBSETA'
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c CLETIKET = '1OBSPRES'
c IERR = VFSTECR(ZTRANSP,ZTRANSP,IPAK,IULSSF,IDATEO
c S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
c S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
c
CLNOMVAR = 'UU'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMU(JK,IDATA)*RKNTMS/ZNORMB
ZTRANSP(JLON,NJ-JLAT+1) = GOMU(JK,IDATA)*RKNTMS/ZNORMB
C-----------Compute UU on P levels
IF(JK.gt.1) then
zgrad=GOMUG(JK,IDATA)-GOMUG(JK-1,IDATA)
ZP1 = RPPOBS(JK-1,IDATA)
ZP2 = RPPOBS(JK,IDATA)
zpresbpb = ((vhybinc(jk) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS2 = -(ZPRESBPB/ZP2)*LOG(ZP2/ZP1)
zpress= GOMU(JK,IDATA) +
+ zgrad*ZDADPS2*GOMPS(1,IDATA)
ZTRANSP(JLON,NJ-JLAT+1)= zpress*RKNTMS/ZNORMB
ENDIF
END DO
END DO
C
CLETIKET = '1OBSETA'
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c CLETIKET = '1OBSPRES'
c IERR = VFSTECR(ZTRANSP,ZTRANSP,IPAK,IULSSF,IDATEO
c S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
c S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
c
CLNOMVAR = 'VV'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMV(JK,IDATA)*RKNTMS/ZNORMB
ZTRANSP(JLON,NJ-JLAT+1) = GOMV(JK,IDATA)*RKNTMS/ZNORMB
C-----------Compute VV on P levels
IF(JK.gt.1) then
zgrad=GOMVG(JK,IDATA)-GOMVG(JK-1,IDATA)
ZP1 = RPPOBS(JK-1,IDATA)
ZP2 = RPPOBS(JK,IDATA)
zpresbpb = ((vhybinc(jk) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS2 = -(ZPRESBPB/ZP2)*LOG(ZP2/ZP1)
zpress= GOMV(JK,IDATA) +
+ zgrad*ZDADPS2*GOMPS(1,IDATA)
ZTRANSP(JLON,NJ-JLAT+1)= zpress*RKNTMS/ZNORMB
ENDIF
END DO
END DO
C
CLETIKET = '1OBSETA'
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c CLETIKET = '1OBSPRES'
c IERR = VFSTECR(ZTRANSP,ZTRANSP,IPAK,IULSSF,IDATEO
c S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
c S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
c
CLNOMVAR = 'TT'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMT(JK,IDATA)/ZNORMB
ZTRANSP(JLON,NJ-JLAT+1) = GOMT(JK,IDATA)/ZNORMB
C-----------Compute TT on P levels
IF(JK.gt.1) then
zgrad=GOMTG(JK,IDATA)-GOMTG(JK-1,IDATA)
ZP1 = RPPOBS(JK-1,IDATA)
ZP2 = RPPOBS(JK,IDATA)
zpresbpb = ((vhybinc(jk) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS2 = -(ZPRESBPB/ZP2)*LOG(ZP2/ZP1)
zpress= GOMT(JK,IDATA) +
+ zgrad*ZDADPS2*GOMPS(1,IDATA)
ZTRANSP(JLON,NJ-JLAT+1)= zpress/ZNORMB
ENDIF
END DO
END DO
C
CLETIKET = '1OBSETA'
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c CLETIKET = '1OBSPRES'
c IERR = VFSTECR(ZTRANSP,ZTRANSP,IPAK,IULSSF,IDATEO
c S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
c S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
C
enddo
c
CLNOMVAR = 'GZ'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMGZ(JK,IDATA)/(ZNORMB*RG*10.0)
ZTRANSP(JLON,NJ-JLAT+1) = GOMGZ(JK,IDATA)/(ZNORMB*RG*10.0)
C-----------Compute GZ on P levels
IF(JK.gt.1) then
zgrad=GOMGZG(JK,IDATA)-GOMGZG(JK-1,IDATA)
ZP1 = RPPOBS(JK-1,IDATA)
ZP2 = RPPOBS(JK,IDATA)
zpresbpb = ((vhybinc(jk) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS2 = -(ZPRESBPB/ZP2)*LOG(ZP2/ZP1)
zpress= GOMGZ(JK,IDATA) +
+ zgrad*ZDADPS2*GOMPS(1,IDATA)
ZTRANSP(JLON,NJ-JLAT+1)= zpress/(ZNORMB*RG*10.0)
ENDIF
END DO
END DO
C
CLETIKET = '1OBSETA'
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c CLETIKET = '1OBSPRES'
c IERR = VFSTECR(ZTRANSP,ZTRANSP,IPAK,IULSSF,IDATEO
c S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
c S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
c
CLNOMVAR = 'P0'
CLETIKET = '1OBSETA'
ip1=0
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMPS(1,IDATA)*1.0e-2/ZNORMB
END DO
END DO
C
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
c****************************************************************************
c WRITE OUT BACKGROUND FIELD
c
CLETIKET = '1OBSBG '
c
CLNOMVAR = 'LQ'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = exp(GOMQG(JK,IDATA))
END DO
END DO
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
c
CLNOMVAR = 'ES'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMESG(JK,IDATA)
END DO
END DO
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
c
CLNOMVAR = 'UU'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMUG(JK,IDATA)*RKNTMS
END DO
END DO
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
c
CLNOMVAR = 'VV'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMVG(JK,IDATA)*RKNTMS
END DO
END DO
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
enddo
c
CLNOMVAR = 'TT'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMTG(JK,IDATA) - tcdk
END DO
END DO
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
enddo
c
CLNOMVAR = 'GZ'
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMGZG(JK,IDATA)/(RG*10.0)
END DO
END DO
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
enddo
c
CLNOMVAR = 'P0'
ip1=0
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
ZTRANSE(JLON,NJ-JLAT+1) = GOMPSG(1,IDATA)*1.0e-2
END DO
END DO
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CLNOMVAR,CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
c
IERR = FSTFRM (IULSSF)
IERR = FCLOS (IULSSF)
c
CALL HPDEALLC(PXTRANSE,IERR,1)
CALL HPDEALLC(PXTRANSP,IERR,1)
C
RETURN
END