!-------------------------------------- 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 sumvogf 1,6
*
#if defined (DOC)
*
***s/r sumvogf - Get first guess fields on analysis grid and store in
* in GOMOBSG for ONEOBS and effective variances experiments
*
*Author : C. Charette *ARMA/AES - 20 nov 98
*Revision:
* S. Pellerin *ARMA/SMC May 2000
* . Logical unit cleanup
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
*
* -------------------
** 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 "comcst.cdk"
#include "comphy.cdk"
#include "comdimo.cdk"
#include "commvog.cdk"
#include "com1obs.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "rpnstd.cdk"
*
C
INTEGER jlev,ji,jj,ILAT,ilon
INTEGER ILEN,IDATA,JDATA
REAL*8 ZTRANS(NI,NJ)
POINTER (PXTRANS,ZTRANS)
C
integer vfstlir
EXTERNAL ABORT3D,vfstlir
*-----------------------------------------------------------
WRITE(NULOUT,FMT='(/,4X,"Starting SUMVOGF",//)')
C
C
C* 1. Open the file
C . -------------
C
************************************************************
100 CONTINUE
C
C* 2 Allocate space for the buffer
C -----------------------------
C
200 CONTINUE
ILEN = NI*NJ
CALL HPALLOC(PXTRANS,MAX(ILEN,1),IERR,8)
C
C* 3. Read desired fields
C . -------------------
C
300 CONTINUE
IDATE(1) = -1
CLETIKET = ' '
CLTYPVAR = 'P'
c
c Temperature
c
write(nulout,*)'reading TT'
CLNOMVAR = 'TT'
IP2 = -1
IP3 = -1
do JLEV = 1,NFLEV
IERR = VFSTLIR(ZTRANS,NINMPG,INI,INJ,INK,IDATE(1)
S ,CLETIKET,NIP1(jlev),IP2,IP3,CLTYPVAR,CLNOMVAR)
IERR = FSTPRM(IERR,IDATEO,IDEET,INPAS
+ ,INI,INJ,INK, INBITS, IDATYP
+ ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
if(IERR.GE.0) then
c Fill in only latitudinally varying gomobsg for HBHT calculation
if(NOBTOT.eq.NJ) then
IDATA = 0
ILON = 1
DO jj = 1, NJ
IDATA=IDATA+1
gomtg(jlev,IDATA) = ZTRANS(ILON,NJ-JJ+1) + TCDK
END DO
c Fill in 2D grid for ONEOBS stuff
elseif(NOBTOT.eq.(NI*NJ)) then
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomtg(jlev,IDATA) = ZTRANS(JI,NJ-JJ+1) + TCDK
enddo
enddo
c ELSE fill in entire gomobsg with profile at NI1OBSLA
else
ILAT=NI1OBSLA
ILON=NI1OBSLO
DO JDATA=1,NOBTOT
gomtg(jlev,jdata) = ZTRANS(ILON,NJ-ILAT+1) + TCDK
enddo
endif
endif
enddo
c
c
c Specific humidity
c
write(nulout,*)'reading HU'
CLNOMVAR = 'HU'
IP2 = -1
IP3 = -1
do JLEV = 1,NFLEV
IERR = VFSTLIR(ZTRANS,NINMPG,INI,INJ,INK,IDATE(1)
S ,CLETIKET,NIP1(jlev),IP2,IP3,CLTYPVAR,CLNOMVAR)
IERR = FSTPRM(IERR,IDATEO,IDEET,INPAS
+ ,INI,INJ,INK, INBITS, IDATYP
+ ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
if(IERR.GE.0) then
c Fill in only latitudinally varying gomobsg for HBHT calculation
if(NOBTOT.eq.NJ) then
IDATA = 0
ILON = 1
DO jj = 1, NJ
IDATA=IDATA+1
gomqg(jlev,IDATA) = log(ZTRANS(ILON,NJ-JJ+1))
END DO
c Fill in 2D grid for ONEOBS stuff
elseif(NOBTOT.eq.(NI*NJ)) then
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomqg(jlev,IDATA) = log(ZTRANS(JI,NJ-JJ+1))
enddo
enddo
c ELSE fill in entire gomobsg with profile at NI1OBSLA
else
ILAT=NI1OBSLA
ILON=NI1OBSLO
DO JDATA=1,NOBTOT
gomqg(jlev,jdata) = log(ZTRANS(ILON,NJ-ILAT+1))
enddo
endif
endif
enddo
c
c
c U-component
c
write(nulout,*)'reading UU'
CLNOMVAR = 'UU'
IP2 = -1
IP3 = -1
do JLEV = 1,NFLEV
IERR = VFSTLIR(ZTRANS,NINMPG,INI,INJ,INK,IDATE(1)
S ,CLETIKET,NIP1(jlev),IP2,IP3,CLTYPVAR,CLNOMVAR)
IERR = FSTPRM(IERR,IDATEO,IDEET,INPAS
+ ,INI,INJ,INK, INBITS, IDATYP
+ ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
if(IERR.GE.0) then
c Fill in only latitudinally varying gomobsg for HBHT calculation
if(NOBTOT.eq.NJ) then
IDATA = 0
ILON = 1
DO jj = 1, NJ
IDATA=IDATA+1
gomug(jlev,IDATA) = ZTRANS(ILON,NJ-JJ+1) * RKNTMS
END DO
c Fill in 2D grid for ONEOBS stuff
elseif(NOBTOT.eq.(NI*NJ)) then
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomug(jlev,IDATA) = ZTRANS(JI,NJ-JJ+1) * RKNTMS
enddo
enddo
c ELSE fill in entire gomobsg with profile at NI1OBSLA
else
ILAT=NI1OBSLA
ILON=NI1OBSLO
DO JDATA=1,NOBTOT
gomug(jlev,jdata) = ZTRANS(ILON,NJ-ILAT+1) * RKNTMS
enddo
endif
endif
enddo
c
c
c V-component
c
write(nulout,*)'reading VV'
CLNOMVAR = 'VV'
IP2 = -1
IP3 = -1
do JLEV = 1,NFLEV
IERR = VFSTLIR(ZTRANS,NINMPG,INI,INJ,INK,IDATE(1)
S ,CLETIKET,NIP1(jlev),IP2,IP3,CLTYPVAR,CLNOMVAR)
IERR = FSTPRM(IERR,IDATEO,IDEET,INPAS
+ ,INI,INJ,INK, INBITS, IDATYP
+ ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
if(IERR.GE.0) then
c Fill in only latitudinally varying gomobsg for HBHT calculation
if(NOBTOT.eq.NJ) then
IDATA = 0
ILON = 1
DO jj = 1, NJ
IDATA=IDATA+1
gomvg(jlev,IDATA) = ZTRANS(ILON,NJ-JJ+1) * RKNTMS
END DO
c Fill in 2D grid for ONEOBS stuff
elseif(NOBTOT.eq.(NI*NJ)) then
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gomvg(jlev,IDATA) = ZTRANS(JI,NJ-JJ+1) * RKNTMS
enddo
enddo
c ELSE fill in entire gomobsg with profile at NI1OBSLA
else
ILAT=NI1OBSLA
ILON=NI1OBSLO
DO JDATA=1,NOBTOT
gomvg(jlev,jdata) = ZTRANS(ILON,NJ-ILAT+1) * RKNTMS
enddo
endif
endif
enddo
c
c Surface pressure
c
write(nulout,*)'reading P0'
CLNOMVAR = 'P0'
IP2 = -1
IP3 = -1
IERR = VFSTLIR(ZTRANS,NINMPG,INI,INJ,INK,IDATE(1)
S ,CLETIKET,0,IP2,IP3,CLTYPVAR,CLNOMVAR)
IERR = FSTPRM(IERR,IDATEO,IDEET,INPAS
+ ,INI,INJ,INK, INBITS, IDATYP
+ ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
if(IERR.GE.0) then
c Fill in only latitudinally varying gomobsg for HBHT calculation
if(NOBTOT.eq.NJ) then
IDATA = 0
ILON = 1
DO jj = 1, NJ
IDATA=IDATA+1
gompsg(1,IDATA) = ZTRANS(ILON,NJ-JJ+1) * RMBTPA
END DO
c Fill in 2D grid for ONEOBS stuff
elseif(NOBTOT.eq.(NI*NJ)) then
IDATA=0
do JI=1,NI
do JJ = 1, NJ
IDATA=IDATA+1
gompsg(1,IDATA) = ZTRANS(JI,NJ-JJ+1) * RMBTPA
enddo
enddo
c ELSE fill in entire gomobsg with profile at NI1OBSLA
else
ILAT=NI1OBSLA
ILON=NI1OBSLO
DO JDATA=1,NOBTOT
gompsg(1,JDATA) = ZTRANS(ILON,NJ-ILAT+1) * RMBTPA
enddo
endif
endif
C
C* 4. Close the file and release memory
C . ---------------------------------
C
CALL HPDEALLC(PXTRANS,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'SUMVOGF. Problem with ZTRANS.')
END IF
C
RETURN
END