subroutine su1obsbg 1,13
*
#if defined (DOC)
*
***s/r su1obsbg - Get first guess fields on analysis grid and store in
* in GOMOBSG for ONEOBS
*
*Author : M. Buehner *ARMA/MSC - nov 2001
*Revision: C. Charette *ARMA/MSC - jun 2002
* - replaced subackgrd by subasic
* M. Buehner *ARMA/MSC - jan 2003
* - fixed bugs for reading in bg field
* C. Charette - ARMA/SMC - Sep. 2004
* - Conversion to hybrid vertical coordinate
* Y. Yang and Y. Rochon MSC Apr.2004
* - Added include "comchem.cdk" for chemistry
* - Added treatment for ozone and other chemical species
*
* -------------------
** Purpose: Setup for Project Background statistics into observation space
* . using first guess for background fields
*Arguments
*
#endif
C
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comdimo.cdk"
#include "commvog.cdk"
#include "commvo.cdk"
#include "comgem.cdk"
#include "comgdpar.cdk"
#include "rpnstd.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "comchem.cdk"
C
INTEGER jlev,ji,jj,ILAT,ilon,igdgid,ezqkdef
INTEGER ILEN,IDATA,JDATA,IDATA2
INTEGER nn, kk
REAL*8 ZTRANS(NI,NJ,NFLEV),ZTRANS2(NI,NFLEV,NJ),
+ zvvg(ni,nj,nflev),ZTRANS2D(NI,1,NJ)
REAL*8 ZPS(1)
POINTER (PXTRANS,ZTRANS),(PXTRANS2,ZTRANS2),(PXTRANS2D,ZTRANS2D),
+ (pxvvg,zvvg),(pxps,zps)
C
EXTERNAL ABORT3D
*-----------------------------------------------------------
WRITE(NULOUT,FMT='(/,4X,"Starting SU1OBSBG",//)')
igdgid = ezqkdef(ni, nj, 'G', 0,0,0,0,0)
C
C* 2 Allocate space for the buffers
C -----------------------------
C
200 CONTINUE
CALL HPALLOC(PXTRANS ,MAX(ni*nj*nflev,1),IERR,8)
CALL HPALLOC(PXTRANS2 ,MAX(ni*nj*nflev,1),IERR,8)
CALL HPALLOC(PXTRANS2D,MAX(ni*nj,1),IERR,8)
CALL HPALLOC(PXvvg,max(ni*nj*nflev,1),IERR,8)
CALL HPALLOC(PXps,max(ni*nj,1),IERR,8)
C
C* 3. Read desired fields
C . -------------------
C
c Temperature
c
write(nulout,*)'reading TT'
CLNOMVAR = 'TT'
call vhfstfld(ztrans,ni*nj,igdgid,zvvg,ni*nj,igdgid,nflev
& ,vhybinc,clnomvar,nbrpstamp,ninmpg,nulout,jpnflev,.true.
& ,'LINEAR')
CALL INITGDG2(ztrans2,ztrans,NI,NJ,NFLEV,0,CLNOMVAR)
do JLEV = 1,NFLEV
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomtg(JLEV,IDATA) = ZTRANS2(JI,JLEV,JJ)
enddo
enddo
enddo
c
c Geopotential Height
c
write(nulout,*)'reading GZ'
call vflush(nulout)
CLNOMVAR = 'GZ'
call vhfstfld(ztrans,ni*nj,igdgid,zvvg,ni*nj,igdgid,nflev
& ,vlev,clnomvar,nbrpstamp,ninmpg,nulout,jpnflev,.true.
& ,'LINEAR')
C
CALL INITGDG2(ztrans2,ztrans,NI,NJ,NFLEV,0,CLNOMVAR)
c
do JLEV = 1,NFLEV
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomgzg(JLEV,IDATA) = ZTRANS2(JI,JLEV,JJ)
enddo
enddo
enddo
c
c Specific humidity
c
write(nulout,*)'reading HU'
CLNOMVAR = 'HU'
call vhfstfld(ztrans,ni*nj,igdgid,zvvg,ni*nj,igdgid,nflev
& ,vhybinc,clnomvar,nbrpstamp,ninmpg,nulout,jpnflev,.true.
& ,'LINEAR')
CALL INITGDG2(ztrans2,ztrans,NI,NJ,NFLEV,0,CLNOMVAR)
do JLEV = 1,NFLEV
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomqg(jlev,IDATA) = log(max(ZTRANS2(JI,JLEV,JJ),rminhu))
if(gomqg(jlev,idata).gt.1000.0)
+ write(nulout,*) 'LOG HU=',jlev,idata,gomqg(jlev,idata)
enddo
enddo
enddo
c
c U-component
c
write(nulout,*)'reading UU and VV'
CLNOMVAR = 'UU'
call vhfstfld(ztrans,ni*nj,igdgid,zvvg,ni*nj,igdgid,nflev
& ,vhybinc,'UV',nbrpstamp,ninmpg,nulout,jpnflev,.true.
& ,'LINEAR')
CALL INITGDG2(ztrans2,ztrans,NI,NJ,NFLEV,0,CLNOMVAR)
do JLEV = 1,NFLEV
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomug(jlev,IDATA) = ZTRANS2(JI,JLEV,JJ)*CONPHY(JJ)
enddo
enddo
enddo
c
c V wind component
c
CLNOMVAR = 'VV'
CALL INITGDG2(ztrans2,zvvg,NI,NJ,NFLEV,0,CLNOMVAR)
do JLEV = 1,NFLEV
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomvg(jlev,IDATA) = ZTRANS2(JI,JLEV,JJ)*CONPHY(JJ)
enddo
enddo
enddo
c
c Surface pressure
c
write(nulout,*)'reading P0'
CLNOMVAR = 'P0'
call vhfstfld(ztrans,ni*nj,igdgid,zvvg,ni*nj,igdgid,1
& ,vhybinc,clnomvar,nbrpstamp,ninmpg,nulout,jpnflev,.true.
& ,'LINEAR')
CALL INITGDG2(ZTRANS2D,ZTRANS,NI,NJ,1,0,CLNOMVAR)
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gompsg(1,IDATA) = ZTRANS2D(JI,1,JJ)
zps(idata) = gompsg(1,IDATA)
enddo
enddo
c
c TEMPORARY: SET ALL BG GRIDPOINTS TO VALUES AT OBS LOCATION
c IDATA = ((NI1OBSLO-1)*NJ)+NI1OBSLA
c do JLEV = 1,NFLEV
c do IDATA2=1,NOBTOT
c gomug(jlev,IDATA2) = gomug(jlev,IDATA)
c gomvg(jlev,IDATA2) = gomvg(jlev,IDATA)
c gomtg(jlev,IDATA2) = gomtg(jlev,IDATA)
c gomqg(jlev,IDATA2) = gomqg(jlev,IDATA)
c gomgzg(jlev,IDATA2)= gomgzg(jlev,IDATA)
c enddo
c enddo
c do IDATA2=1,NOBTOT
c gompsg(1,IDATA2) = gompsg(1,IDATA)
c enddo
C
C Setup RPPOBS, RMTMOBS, other variable types in gomobsg
C
do ji = 1,nobtot
zps(ji) = gompsg(1,ji)
enddo
call calcpres(RPPOBS(1,1),vhybinc,nflev,zps,rptopinc
& ,rprefinc,rcoefinc,nobtot)
DO JI=1, NOBTOT
RMTMOBS(JI) = gomgzg(nflev,ji)
enddo
c
c Chemistry species
c
do kk= 1, NFSTVAR
DO NN= 1, NOCMT
IF(CFSTVAR(kk).EQ.CMVOCMT(NN)) THEN
write(nulout,*)'reading ', CFSTVAR(kk)
CLNOMVAR = CFSTVAR(kk)
call vhfstfld(ztrans,ni*nj,igdgid,zvvg,ni*nj,igdgid,nflev
& ,vhybinc,clnomvar,nbrpstamp,ninmpg,nulout,jpnflev,.true.
& ,'LINEAR')
CALL INITGDG2(ztrans2,ztrans,NI,NJ,NFLEV,0,CLNOMVAR)
do JLEV = 1,NFLEV
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomtrg((NN-1)*nflev+jlev,IDATA) = ZTRANS2(JI,JLEV,JJ)
enddo
enddo
enddo
ENDIF
ENDDO
enddo !nfstvar
C
call subasic_obs
call preobs
C
C* 4. Close the file and release memory
C . ---------------------------------
C
call hpdeallc(pxvvg,ierr,1)
CALL HPDEALLC(PXTRANS ,IERR,1)
CALL HPDEALLC(PXTRANS2 ,IERR,1)
CALL HPDEALLC(PXTRANS2D,IERR,1)
C
RETURN
END