!-------------------------------------- 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 HBHT 1,25
#if defined (DOC)
*
***s/r HBHT - Calculate background standard deviations for observed
* variable types on the analysis grid to be stored in the
* statistics file
*
*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 FEB 2000
* - Read mean background fields from stats file CSTAT
* associated to unit NULSTAT. Read in PP field to
* get parameters to output file.
* S. Pellerin *ARMA/SMC May 2000
* - Logical unit cleanup
* - Fix for F90 conversion
* JM Belanger CMDA/SMC Aug 2000
* . 32 bits conversion
* C. CHARETTE ARMA/SMC MAY 2001
* VLAYERS--->VOBSLYRS
* C. CHARETTE ARMA/SMC MAY 2002
* Adapted to run with v9.2.0
* C. Charette *ARMA/SMC - Sept 2004
* - Conversion to hybrid vertical coordinate
* S. Pellerin, ARMA, Jan. 09
* - Call to new obs operators (ODA)
*
* -------------------
** Purpose: Project Background statistics into observation space
*
* NOTE: WHEN C1OBSTP IS 'DZ' FOR THE 7 THICKNESSES OF SATEMS YOU
* HAVE TO CHANGE THE STATEMENT
* PARAMETER(IFLEV=28) TO PARAMETER(IFLEV=7)
* .
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "comcst.cdk"
#include "comphy.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "com1obs.cdk"
#include "cvcord.cdk"
#include "comstate.cdk"
#include "rpnstd.cdk"
C
INTEGER IFLEV,JPDZLEV
PARAMETER (JPDZLEV=7)
INTEGER FNOM,FSTOUV,FSTFRM,FCLOS,VFSTLIR,VFSTECR
INTEGER ILEN,ILAT(4),IULOUT,IPOS,IEL,ITIME,IDATEB,IRUNN,IKEY
INTEGER JLAT,JL2,JK,JJK,JK2,JLA,JJ,jlev,jobs,JO
INTEGER INIV(2),ISTPLIST(JPDZLEV),ISTRLIST(JPDZLEV)
REAL*8 ZLON(4),ZPS(4),zvariance
C
real*8, allocatable, dimension(:,:) :: ZSTDOUT,ZTRANS
REAL*8 ZJO,CONV
C
REAL*8 ZTBUFFER(NJ,NFLEV),ZPBUFFER(NJ,NFLEV),ZHBUFFER(NJ,NFLEV)
POINTER (PTBUFFER,ZTBUFFER)
POINTER (PHBUFFER,ZHBUFFER)
POINTER (PPBUFFER,ZPBUFFER)
DATA ISTPLIST/1000,3000,5000,10000,30000,50000,70000/
DATA ISTRLIST/3000,5000,10000,30000,50000,70000,100000/
C
WRITE(NULOUT,FMT='(/,4X,"Starting HBHT",//)')
C
NOBTOT=4
NFILES=1
NBEGINTYP(1)=1
NENDTYP(1)=4
CFAMTYP(1) = 'UA'
INIV(1)=70000
INIV(2)=100000
C
IF ( C1OBSTP .eq. 'DZ') then
allocate(ZSTDOUT(NJ,JPDZLEV))
allocate(ZTRANS(NJ,JPDZLEV))
IFLEV = JPDZLEV
ELSE
allocate(ZSTDOUT(NJ,NFLEV))
allocate(ZTRANS(NJ,NFLEV))
IFLEV = NFLEV
ENDIF
C
IF ( C1OBSTP .eq. 'UU') then
CONV=RKNTMS
IPOS=nouu-1
IEL=11003
ELSE IF ( C1OBSTP .eq. 'VV') then
CONV=RKNTMS
IPOS=novv-1
IEL=11004
ELSE IF ( C1OBSTP .eq. 'GZ') then
CONV=1./(RG*10.)
IPOS=nogz-1
IEL=10194
ELSE IF ( C1OBSTP .eq. 'ES') then
CONV=1.
IPOS=noes-1
IEL=12192
ELSE IF ( C1OBSTP .eq. 'DZ') then
CFAMTYP(1) = 'ST'
CONV=.1
IPOS=nogz-1
IEL=10192
ELSE IF ( C1OBSTP .eq. 'TT') then
CONV=1.
IPOS=nott-1
IEL=12001
ELSE
write(nulout,*) 'Problem: C1OBSTP NOT VALID '
call abort3d(nulout,'HBHT')
ENDIF
C
call sucov('H',NULOUT)
call suscal('I')
c
c
c READ IN ZONALLY AVERAGED MONTHLY MEAN FIELDS
c
ILEN = NJ*NFLEV
CALL HPALLOC(PTBUFFER,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PHBUFFER,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PPBUFFER,MAX(1,ILEN),IERR,8)
*
* 1. Opening the statistics file
*
write(NULOUT,*) 'HBHT: Reading in background state from unit: '
& ,nulbgst
*
* 2. Reading the data
*
CLETIKET = 'MEAN'
IDATE(1) = -1
IP1 = -1
IP2 = -1
IP3 = -1
CLTYPVAR =' '
c
CLNOMVAR = 'TT'
write(NULOUT,*)'reading: ',CLNOMVAR
IKEY = VFSTLIR(ZTBUFFER,nulbgst,INI,INJ,INK,IDATE(1)
S ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
C
c
CLNOMVAR = 'HU'
write(NULOUT,*)'reading: ',CLNOMVAR
IKEY = VFSTLIR(ZHBUFFER,nulbgst,INI,INJ,INK,IDATE(1)
S ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
C
CLNOMVAR = 'P0'
C
write(NULOUT,*)'reading: ',CLNOMVAR
IKEY = VFSTLIR(ZPBUFFER,nulbgst,INI,INJ,INK,IDATE(1)
S ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
c
C
C* 0.1 Memory allocation
C . -----------------
ILEN = NJ*NFLEV
C
DO JLAT = 1, NJ
DO JK=1, IFLEV
ZSTDOUT(JLAT,JK)=0.
ENDDO
ENDDO
C
DO JOBS=1, NOBTOT
RMTMOBS(JOBS) = 10.*RG
enddo
DO JOBS=1,NOBTOT
DO JJK=1, NFLEV
GOMUG(JJK,JOBS) = 0.0
GOMVG(JJK,JOBS) = 0.0
ENDDO
ENDDO
ZLON(1)=0.
ZLON(2)=0.
ZLON(3)= 2.*(119./240.)*RPI
ZLON(4)= 2.*(119./240.)*RPI
c
c
C* 1. Loop over all locations
C . -------------------------------------------
C do every 4'th latitude bin and every vertical level
C
DO JL2 = 1,NJ/2,8
ILAT(1)=JL2
ILAT(2)=JL2 +NJ/2+5-1
ILAT(3)=NJ+5-(JL2-1)
ILAT(4)=NJ/2+1-(JL2-1)
if(ILAT(1).gt.NJ) ILAT(1)=NJ
if(ILAT(2).gt.NJ) ILAT(2)=NJ
if(ILAT(3).gt.NJ) ILAT(3)=NJ
if(ILAT(4).gt.NJ) ILAT(4)=NJ
C
C SETUP TRIAL FIELD
C
C-----------------------------------------------------------------------
DO JOBS=1,NOBTOT
gompsg(1,JOBS) = ZPBUFFER(NJ-ILAT(JOBS)+1,1)*100.0
zps(jobs) = gompsg(1,JOBS)
DO JJK=1, NFLEV
GOMTG (JJK,JOBS) = ZTBUFFER(NJ-ILAT(JOBS)+1,NFLEV-JJK+1)
& + TCDK
GOMQG (JJK,JOBS) = log(ZHBUFFER(NJ-ILAT(JOBS)+1
& ,NFLEV-JJK+1))
ENDDO
ENDDO
call calcpres(RPPOBS(1,1),vhybinc,nflev,zps,rptopinc
& ,rprefinc,rcoefinc,nobtot)
write(nulout,*)'hbht:C1OBSTP= ',C1OBSTP
write(nulout,*)'hbht:ptop,pref,coef',rptopinc,rprefinc,rcoefinc
write(nulout,*)'hbht:rppobs= '
& ,((RPPOBS(jjk,jobs),jjk=1,nflev),jobs=1,nobtot)
call subasic_obs
call preobs
C-----------------------------------------------------------------------
DO JK=1,IFLEV
INIV(1)=ISTPLIST(JK)
INIV(2)=ISTRLIST(JK)
DO JJ=1,NVADIM
VAZX(JJ)=0.
END DO
c
c Set one element to 1.0 others to 0.0
c
C SETUP CMA
C
C-----------------------------------------------------------------------
c
IF(CFAMTYP(1) .EQ. 'UA') THEN
CALL SETUACMA(ZLON,ILAT,JK,IPOS,IEL,NOBTOT)
ELSEIF(CFAMTYP(1) .EQ. 'ST') THEN
CALL SETSTCMA(INIV,ZLON,ILAT,JK,IPOS,IEL,NOBTOT)
ENDIF
CALL VOBSLYRS('BG')
c
C-----------------------------------------------------------------------
c
call oda_sqrtRm1(ncmomi,ncmoma) ! sqrt(R-1)u
CALL TRANSFER('ZOB0')
call oda_HT ! OMI -> Gomobs
CALL TRANSFER('ZGD0')
call oda_LT ! Gomobs -> GD
CALL TRANSFER('ZSP0')
vazx = 0.d0
call oda_sqrtBT(vazx,nvadim) ! GD -> vazx
C
call oda_sqrtB(vazx,nvadim)
call oda_L
call oda_H
call oda_res
call oda_sqrtRm1(ncmoma,ncmoma)
DO JOBS=1,NOBTOT
zvariance = ROBDATA8(NCMOMA,JOBS)
if(ROBDATA8(NCMOMA,JOBS) .lt. 0.0) then
zvariance = 0.0
write(nulout,*)' lev LAT variance negative = '
+ ,JK,ROBHDR(NCMLAT,JOBS),ROBDATA8(NCMOMA,JOBS)*CONV
+ ,ILAT(JOBS)
endif
ZSTDOUT(ILAT(JOBS),JK)=SQRT(zvariance)
END DO
END DO
END DO
c
c Interpolate in the horizontal
c
do JLAT=1,NJ-4,4
do JK=1,IFLEV
ZSTDOUT(JLAT+1,JK)=
+ sqrt(0.75*(ZSTDOUT(JLAT,JK)**2)+0.25*(ZSTDOUT(JLAT+4,JK)**2))
ZSTDOUT(JLAT+2,JK)=
+ sqrt(0.50*(ZSTDOUT(JLAT,JK)**2)+0.50*(ZSTDOUT(JLAT+4,JK)**2))
ZSTDOUT(JLAT+3,JK)=
+ sqrt(0.25*(ZSTDOUT(JLAT,JK)**2)+0.75*(ZSTDOUT(JLAT+4,JK)**2))
enddo
enddo
c
do JK=1,IFLEV
ZSTDOUT(NJ-2,JK)=
+ sqrt((2.0/3.0)*(ZSTDOUT(NJ-3,JK)**2)+
+ (1.0/3.0)*(ZSTDOUT(NJ,JK)**2))
ZSTDOUT(NJ-1,JK)=
+ sqrt((1.0/3.0)*(ZSTDOUT(NJ-3,JK)**2)+
+ (2.0/3.0)*(ZSTDOUT(NJ,JK)**2))
enddo
c
c 2. Write out to statistics file for desired variable
c
iulout = 0
IERR = FNOM(IULOUT,'stddevbg.fst','RND',0)
IERR = FSTOUV(IULOUT,'RND')
C
IDATE(1) = -1
IP1 = -1
IP2 = -1
IP3 = -1
CLETIKET = ' '
CLNOMVAR = 'PP'
CLTYPVAR ='E'
IKEY = FSTINF(NULBGST,INI,INJ,INK,IDATE(1)
S ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
C
IERR = FSTPRM(IKEY,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)
c
*******************************************************************
* ATTN ATTN ATTN ATTN ATTN ATTN ATTN ATTN ATTN ATTN
*
* POUR UNE RAISON INCONNUE SI ON LAISSE LE COMPILATEUR NEC
* VECTORIZER LA BOUCLE EXTERIEURE, ZTRANS VA AFFECTER L'ESPACE
* DYNAMIQUE RESERVE PAR LE POINTEUR 'PXH2' CREANT UN ABORT A LA
* DE-ALLOCATION DE CET ESPACE.
**** A NE PAS ENLEVER POUR L'INSTANT ******
*(C.CHARETTE, M. LEPINE 3 DECEMBRE 1998)
*********************************************************************
C
*vdir novector
do jk=1,IFLEV
DO jlat = 1, NJ
ZTRANS(NJ-JLAT+1,JK) = ZSTDOUT(JLAT,JK)*CONV
END DO
ENDDO
C
CLNOMVAR=C1OBSTP
IERR = VFSTECR(ZTRANS,ZTRANS,-INBITS,IULOUT,IDATEO
S ,0,0,1,nj,iflev,IP1,IP2,IP3,'E'
S ,CLNOMVAR,'STDDEV','X',0,0,0,0,IDATYP,.TRUE.)
*
c
IERR = FSTFRM (IULOUT)
IERR = FCLOS (IULOUT)
c
CALL HPDEALLC(PTBUFFER,IERR)
CALL HPDEALLC(PHBUFFER,IERR)
CALL HPDEALLC(PPBUFFER,IERR)
deallocate(ZSTDOUT)
deallocate(ZTRANS)
RETURN
END