SUBROUTINE CH_ONEOBS 1,31
use mod4dv, only : l4dvar
#if defined (DOC)
*
***s/r CH_ONEOBS - Calculate a normalized column of B directly for comparison
* with results from single obs experiment
*
*Author : Y. Yang, March 2005
* - This is a version of ONEBOS by Mark Buehner, October 1998,
* adapted for use with species obs, including total and partial
* columns
*Revision: (see oneobs.ftn)
* Y. Yang Apr. 2004
* 1. Added calculation for total/partial column data
* (forward and adjoint model)
* 2. 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.
* 3. 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.
* 4. Added integer ICORDTYP to distinguish between profile and
* total/partial column data: (see CH_OBSTYP)
* ICORDTYP = 1 Data at one particular level. Should set as follows
* in the namelist:
* R1OBSLV = pressure at the data level in mb
* R1OBSPTOP : N/A
* R1OBSPBTM : N/A
* R1OBSINO = x-x^obs in ppv
* ICORDTYP = 3 for total or partial column data.
* Should set as follows in the namelist:
* R1OBSLV : N/A
* R1OBSPTOP = pressure at the layer top in mb
* R1OBSPBTM = pressure at the layer bottom in mb
* Set to 1200.0 mb if to be total column.
* R1OBSINO = x-x^obs in kg/m^2
* 5. Added include "comchem.cdk" for chemistry
* C.Charette ARMA/AES SEP 2004
* - Added option to move observation to nearest analysis level via
* namelist (see LVLNEAR)
*
* Y.J. Rochon, Apil 2007
* - Added output of species to RPN file even if the obs is
* not the specified species (for multivariation assimilation)
*
* -------------------
** 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"
#include "comchem.cdk"
*
C
INTEGER IDATA,JLAT,JLON,ILEV,JK,IULSSF,JLA,IFIRST
INTEGER ILAT,ILON,ILEV1,ILEV2
REAL*8 ZTRANSE(NI,NJ),ZTRANSP(NI,NJ),ZNORMB,ZSIGOBS,Z1OBSLV
REAL*8 ZTRANSR(NI,NJ)
REAL*8 ZGRAD,ZP1,ZP2,ZDADPS2,ZPRESS,zpresbpb,zpresbpt, ZSCALE
REAL*8 ZWT, ZWB
POINTER(PXTRANSE,ZTRANSE),(PXTRANSP,ZTRANSP)
INTEGER NN, NLEV, KK, LL
REAL*8 TOTCOLM, DVPS
REAL*8 ptop, pbtm
real*8 epsilon
real*8 zh(jpnflev),zhp(jpnflev)
C
integer vfstecr
external vfstecr
real*8 vtr(nflev)
INTEGER ITOT
REAL*8 ZSTATE(nflev)
C
*-------------------------------------------------------------------
C
epsilon = 2.0e-16 ! machine precision
ZSCALE=1.0d-5
ZTRANSR(:,:) = 0.0
WRITE(NULOUT,FMT='(/,4X,"Starting CH_ONEOBS",//)')
write(nulout,*) 'ch_oneobs: before nobtot=',nobtot
NOBTOT=NJ*NI
write(nulout,*) 'ch_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
do jk=1,NKGDIMO
write(NULOUT,*) 'ch_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 ICORDTYP = 1 implies that the input O-P is at one particular point
C
if (ICORDTYP .eq. 1) then
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
C
write(NULOUT,*) 'CH_ONEOBS:NI1OBS= ',NI1OBSLA,NI1OBSLO,NI1OBSLV
write(NULOUT,*) 'CH_ONEOBS: vlev = ', vlev
write(NULOUT,*) 'CH_ONEOBS: vhybinc = ', vhybinc
C
ILEV=NI1OBSLV
C
IF(LVLNEAR) THEN
write(NULOUT,*) 'CH_ONEOBS:OBSERVATION MOVED TO NEAREST'
& ,' VERTICAL LEVEL LVLNEAR= ',LVLNEAR
Z1OBSLV = RPPOBS(ILEV,IDATA)
ILEV1 = MAX(ILEV-1,1)
ILEV2 = MAX(ILEV,2)
write(NULOUT,*) 'CH_ONEOBS:level specified= ',R1OBSLV*100
& ,' nearest level= ', Z1OBSLV
ELSE
write(NULOUT,*) 'CH_ONEOBS:OBSERVATION ASSIMILATED AT ITS'
& ,' SPECIFIED LEVEL LVLNEAR= ',LVLNEAR,' level= ',Z1OBSLV
& ,' PA'
ENDIF
C
write(NULOUT,*)
& 'CH_ONEOBS:Z1OBSLV,ilev1,ilev2,RPPOBS(ilev1),,RPPOBS(ilev2)'
& ,Z1OBSLV,ilev1,ilev2,RPPOBS(ilev1,IDATA),RPPOBS(ilev2,IDATA)
write(NULOUT,*) 'CH_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 Do adjoint of vertical interpolation
C
IF(ILEV.gt.1.and.C1OBSTP.ne.'P0') then
ZP1 = RPPOBS(ILEV1,IDATA)
ZP2 = RPPOBS(ILEV2,IDATA)
ZWB = LOG(Z1OBSLV/ZP1)/LOG(ZP2/ZP1)
ZWT = 1. - ZWB
C
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
ENDIF
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,*)'ch_oneobs:C1OBSTP,IDATA,LEV,vlev(LEV),R1OBSINO= '
& ,C1OBSTP,IDATA,ILEV,vlev(ILEV),R1OBSINO
write(nulout,*)'ch_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,*)'ch_oneobs:C1OBSTP,IDATA,LEV,vlev(LEV),R1OBSINO= '
& ,C1OBSTP,IDATA,ILEV,vlev(ILEV),R1OBSINO
IF(ILEV.gt.1) THEN
write(nulout,*)'ch_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
C
C chemistry species
C
else
DO NN= 1,NOCMT
if(C1OBSTP.eq.CMVOCMT(NN) .and. NMVOEXIST(notr(nn)).eq.1) then
nlev = (nn-1)*nflev + ilev1
GOMTR(nlev+1,IDATA) = GOMTR(nlev+1,IDATA) + ZWB* R1OBSINO
GOMTR(nlev,IDATA) = GOMTR(nlev,IDATA) + ZWT* R1OBSINO
IF(ILEV.gt.1)
+ zgrad= 0.0
go to 999
endif
ENDDO
999 continue
if (nn .GT. nocmt) then
write(NULOUT,*) 'BACKGROUND FIELD FOR OBS TYPE DOES NOT EXIST!!'
call abort3d(NULOUT,'CH_ONEOBS')
endif
endif
c
IF(ILEV.gt.1.and.C1OBSTP.ne.'P0') then
C
GOMPS(1,IDATA) = zgrad*ZDADPS2*R1OBSINO
***************************************************************
write(nulout,*)'ch_oneobs: IDATA,ILEV,zp1,zp2,zwt,zwb,vlev(ILEV)= '
& ,IDATA,ILEV,zp1,zp2,zwt,zwb,vlev(ILEV)
write(nulout,*)'ch_oneobs: C1OBSTP,R1OBSINO,ZDADPS2,zgrad,gomps= '
& ,C1OBSTP,R1OBSINO,ZDADPS2,ZGRAD,GOMPS(1,IDATA)
***************************************************************
ENDIF
c
ELSEIF (ICORDTYP .eq. 3) THEN
C
C Indicates total column or partial column data.
C First call adjoint of vertical integration .
C
CALL TRANSFER('ZOB0')
CALL TRANSFER('ZOB1')
CALL TRANSFER('ZGD0')
CALL TRANSFER('ZSP0')
totcolm = R1OBSINO
C
C Change pressure from mb to Pascal
C
ptop = R1OBSPTOP *100.0
pbtm = R1OBSPBTM *100.0
vtr = 0.0
C
C Adjoint of the vertical integration
C
ifirst=1
CALL CH_VERTINTG(vtr, ptop, pbtm,
1 RPPOBS(1:nflev,IDATA), nflev, ifirst, zstate,
1 nulout,C1OBSTP,itot,zh,zhp)
totcolm=dot_product(vtr(1:nflev),zh(1:nflev))
C
C put the gradient into GOMOBS
C
DO NN= 1,NOCMT
if(C1OBSTP.eq.CMVOCMT(NN) .and. NMVOEXIST(notr(nn)).eq.1) then
do kk= 1, nflev
nlev = (nn-1)*nflev + kk
gomtr(nlev, idata) = gomtr(nlev, idata) + vtr(kk)
end do
go to 800
endif
ENDDO
800 continue
***************************************************************
ENDIF ! (ICORDTYP .eq. 3)
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
CALL SPGDA
CALL SPA2SPAD
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
CALL SPA2SP
call SPGD
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 Do equivalent of vertical interpolation
C to interpolate from model levels to observation level
C
IF((ICORDTYP .eq.1) .and. (ILEV.gt.1) .and. (C1OBSTP.ne.'P0')) then
ZP1 = RPPOBS(ILEV1,IDATA)
ZP2 = RPPOBS(ILEV2,IDATA)
ZWB = LOG(Z1OBSLV/ZP1)/LOG(ZP2/ZP1)
ZWT = 1. - ZWB
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)
C
C Interpolate to the observation level
C
***************************************************************
write(nulout,*)'ch_oneobs: IDATA,ILEV,zp1,zp2,vlev(ILEV)= '
& ,IDATA,ILEV,zp1,zp2,vlev(ILEV)
write(nulout,*)'ch_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
C
C Chemical species
C
else
DO NN= 1,NOCMT
if(C1OBSTP.eq.CMVOCMT(NN) .and. NMVOEXIST(notr(nn)).eq.1) then
nlev = (nn-1)*nflev + ilev1
ZNORMB = ZWB*GOMTR(nlev+1,IDATA) + ZWT*GOMTR(nlev,IDATA)+dvps
go to 888
endif
ENDDO
888 continue
endif
ENDIF
C
if(C1OBSTP.eq.'P0') then
ZNORMB=GOMPS(1,IDATA)
endif
C
write(nulout,*) 'ch_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
C for total or partial column data
C
IF (ICORDTYP .eq. 3) THEN
C
C chemistry species
DO NN= 1,NOCMT
if(C1OBSTP.eq.CMVOCMT(NN) .and. NMVOEXIST(notr(nn)).eq.1) then
do kk= 1, nflev
vtr(kk) = gomtr((NN-1)*nflev+kk, idata)
end do
go to 900
endif
ENDDO
900 CONTINUE
ZNORMB = 0.0
C
ifirst=1
CALL CH_VERTINTG(vtr, ptop, pbtm,
1 RPPOBS(1:nflev,IDATA), nflev, ifirst, zstate,
1 nulout,C1OBSTP,itot,zh,zhp)
znormb=dot_product(vtr(1:nflev),zh(1:nflev))
C
ENDIF ! (ICORDTYP .eq. 3)
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 since the parameters are not right
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 Chemical species
C
CLNOMVAR = C1OBSTP
DO NN= 1, NOCMT
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
nlev = (nn-1)*nflev + jk
ZTRANSE(JLON,NJ-JLAT+1) = GOMTR(NLEV,IDATA)/ZNORMB
ZTRANSP(JLON,NJ-JLAT+1) = GOMTR(NLEV,IDATA)/ZNORMB
C
C compute species on P levels
C
IF(JK.gt.1) then
zgrad=GOMTRG(NLEV,IDATA)-GOMTRG(NLEV-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= GOMTR(NLEV,IDATA) +
+ zgrad*ZDADPS2*GOMPS(1,IDATA)
ZTRANSP(JLON,NJ-JLAT+1)= zpress/ZNORMB
C
C relative increment
C
if (ABS(GOMTRG(NLEV,IDATA)) .ge. epsilon) then
ZTRANSR(JLON,NJ-JLAT+1)= ZTRANSE(JLON,NJ-JLAT+1)/GOMTRG(NLEV,IDATA)
else
ZTRANSR(JLON,NJ-JLAT+1)= 1.0
endif
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 ,CMVOCMT(NN),CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
CLETIKET = '1OBSREI'
IERR = VFSTECR(ZTRANSR,ZTRANSR,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CMVOCMT(NN),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 ,CMVOCMT(NN),CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c
enddo
ENDDO !NN
C
c total or partial column
C
IF (ICORDTYP .eq. 3) THEN
C
DO LL = 1, NOCMT
c if(C1OBSTP.eq.CMVOCMT(LL)) then
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
do kk= 1, nflev
vtr(kk) = gomtr((LL-1)*nflev+kk, idata)
end do
C
ifirst=1
CALL CH_VERTINTG(vtr, ptop, pbtm,
1 RPPOBS(1:nflev,IDATA), nflev, ifirst, zstate,
1 nulout,C1OBSTP,itot,zh,zhp)
totcolm=dot_product(vtr(1:nflev),zh(1:nflev))
C
ZTRANSE(JLON,NJ-JLAT+1) = totcolm/ZNORMB
C
C relative increment
C
do kk= 1, nflev
vtr(kk) = gomtrg((LL-1)*nflev+kk, idata)
end do
C
ifirst=0
CALL CH_VERTINTG(vtr, ptop, pbtm,
1 RPPOBS(1:nflev,IDATA), nflev, ifirst, zstate,
1 nulout,C1OBSTP,itot,zh,zhp)
totcolm=dot_product(vtr(1:nflev),zh(1:nflev))
C
if (abs(totcolm) .ge. epsilon )then
ZTRANSR(JLON,NJ-JLAT+1) = ZTRANSE(JLON,NJ-JLAT+1)/totcolm
else
ZTRANSR(JLON,NJ-JLAT+1)= 1.0
endif
ENDDO
ENDDO
ip1=0
CLETIKET = '1OBSETA'
IERR = VFSTECR(ZTRANSE,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CMVOCMT(LL),CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
CLETIKET = '1OBSREI'
IERR = VFSTECR(ZTRANSR,ZTRANSE,IPAK,IULSSF,IDATEO
S ,IDEET,IPAS,INI,INJ,INK,IP1,IP2,IP3,CLTYPVAR
S ,CMVOCMT(LL),CLETIKET,CLGRTYP,IG1,IG2,IG3,IG4,IDATYP,.TRUE.)
c endif
ENDDO
C
ENDIF ! (ICORDTYP.eq.3)
C
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
IF (NOCMT.gt.0) THEN
DO NN= 1,NOCMT
CLNOMVAR=CMVOCMT(NN)
do jk=1,NFLEV
ip1=nip1(jk)
IDATA=0
DO jlon = 1, NI
DO jlat = 1, NJ
IDATA=IDATA+1
nlev=(nn-1)*nflev + jk
ZTRANSE(JLON,NJ-JLAT+1) = GOMTRG(nlev,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
ENDDO
END IF
c
IERR = FSTFRM (IULSSF)
IERR = FCLOS (IULSSF)
c
CALL HPDEALLC(PXTRANSE,IERR,1)
CALL HPDEALLC(PXTRANSP,IERR,1)
C
RETURN
END