!-------------------------------------- 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 subasic_obs 2,1
c
IMPLICIT NONE
c
#if defined (DOC)
*
***s/r SUBASIC_OBS
* OBJECT: Initialise background state dependant factors
* and vectors for use in TLM and adjoint of
* non-linear operator
*
* Author : S. Pellerin *ARMA/AES Sept. 98
*
* Note : C. Charette *ARMA/AES Apr. 2006
* This is the version of the module "subasic"
* for the hybrid vertical coordinate of the 3DVAR
* The new name was chosen to indicate that it operates at
* the location of the observations.
*
** Purpose:
* - Copy observation space background fields
* in GOMOBSG.
* - Initialisation of tangent linear vitual temperature operator
* - Initialisation of tlm and adjoint hydrostatic operators
* factors.
* Revision: C. Chouinard *ARMA/AES Sept. 98
* - add definition of TLM and ADJ operators for T-Td conversions
* Revision: L. Filllion *ARMA/AES 24 nov 98
* - Reorganize to support ES and HU options.
* Revision: C. Charette *ARMA/AES mar 99
* - Change module name from subackgrd to subasic
* Replace gomps1 by gomu1
* Revision: C. Charette *ARMA/AES nov 99
* - No projection on TT and PS for T-Td observations
* Revision: C. Charette *ARMA/AES mar 2000
* - No projection on TT and PS for T-Td observations
* from HUMSAT only.
* Revision: C. Charette - ARMA/SMC - Sep. 2004
* - Conversion to hybrid vertical coordinate
* Remove argument PTOP
*Arguments
*
#endif
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comgem.cdk"
#include "comcst.cdk"
#include "commvo.cdk"
#include "commvo1.cdk"
#include "commvog.cdk"
#include "comoahdr.cdk"
#include "comoabdy.cdk"
#include "comoba.cdk"
*
integer jlev,jobs, ity, idburp, ilen,ierr
real*8 zhu, ztd, zterm
EXTERNAL HPDEALLC, HPALLOC
real*8 znut,zpresa,zpresb,zpresad,zpresbd
C
*
#include "comcva.cdk"
#include "comphy.cdk"
#include "dinternv.cdk"
#include "finternv.cdk"
#include "finternva.cdk"
#include "finternvl.cdk"
*
*--------------------------------------------
*
C
if(chum.eq.'ES') then
c
ILEN=NFLEV*NOBTOT
c
ccc call calcpresa(rpresa,rpresad,'BG',vlev,ptop,2,nflev,nobtot)
ccc call calcpresb(rpresb,rpresbd,'BG',vlev,ptop,2,nflev,nobtot)
c
do jlev = 1, nflev
do jobs = 1, nobtot
zhu=exp(gomqg(jlev,jobs))
c
c fields for es to q tl transform
c
ztd = gomtg(jlev,jobs) - gomesg(jlev,jobs)
dlnesg(jlev,jobs) = fodle(ztd)
estdg(jlev,jobs) = foew(ztd)
if(zhu.eq.1.) then
rqgfac(jlev,jobs) = 0.
else
rqgfac(jlev,jobs) = 1.
endif
c
c fields for Tv to GZ tl transform
c
zpresb = ((vhybinc(jlev) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
if((rcoefinc-1.0) .lt. RPRECIS) then
zterm = 1.0
else
zterm = ((vhybinc(jlev) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**(rcoefinc-1.0)
endif
zpresbd= rcoefinc * zterm
zpresa = rprefinc * (vhybinc(jlev)-zpresb)
zpresad= rprefinc * (1.0-zpresbd)
rtapfac(jlev,jobs)= (zpresad+zpresbd*gompsg(1,jobs))
& /(zpresa+zpresb*gompsg(1,jobs))
oltv(1,jlev,jobs) = (1.+delta*zhu)
oltv(2,jlev,jobs) = delta*gomtg(jlev,jobs)
enddo
enddo
c
else
c
c initialize GOMT1 THE ADJOINT to 1.0 to get the operator via the adjoint
c
DO JLEV=1,NFLEV
DO JOBS=1,NOBTOT
GOMT1(JLEV,JOBS) = 1.0
ENDDO
ENDDO
c
ILEN=NFLEV*NOBTOT
c
do jlev = 1,nflev
DO JOBS=1,NOBTOT
zhu=exp(gomqg(jlev,jobs))
oltv(1,jlev,jobs) = fottva(zhu,gomt1(jlev,jobs))
oltv(2,jlev,jobs) = folnqva(zhu,gomtg(jlev,jobs),
& gomt1(jlev,jobs))
c
zpresb = ((vhybinc(jlev) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
if((rcoefinc-1.0) .lt. RPRECIS) then
zterm = 1.0
else
zterm = ((vhybinc(jlev) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**(rcoefinc-1.0)
endif
zpresbd= rcoefinc * zterm
zpresa = rprefinc * (vhybinc(jlev)-zpresb)
zpresad= rprefinc * (1.0-zpresbd)
rtapfac(jlev,jobs)= (zpresad+zpresbd*gompsg(1,jobs))
& /(zpresa+zpresb*gompsg(1,jobs))
enddo
enddo
c
c initialize the operator using the adjoint of the conversion lnq/t to t-td
c initialising the adjoint of t-td=1.0
c
DO JLEV=1,NFLEV
DO JOBS=1,NOBTOT
GOMES1(JLEV,JOBS)= 1.0
GOMQ1(JLEV,JOBS) = 0.0
GOMU1(JLEV,JOBS) = 0.0
GOMT1(JLEV,JOBS) = 0.0
ENDDO
ENDDO
c
call amhuaesv
c
c store the coefficients
c
DO JLEV=1,NFLEV
DO JOBS=1,NOBTOT
OLLQ2ES(1,JLEV,JOBS) = GOMQ1 (JLEV,JOBS)
OLLQ2ES(2,JLEV,JOBS) = GOMU1 (JLEV,JOBS)
OLLQ2ES(3,JLEV,JOBS) = GOMT1 (JLEV,JOBS)
ENDDO
ENDDO
c
c Set coefficients for TT and PS to zero for HUMSAT (IDTYP=158)
c
DO JLEV=1,NFLEV
DO JOBS=1,NOBTOT
ITY = MOBHDR(NCMITY,JOBS)
IDBURP = MOD(ITY,1000)
IF(IDBURP .EQ. 158) THEN
OLLQ2ES(2,JLEV,JOBS) = 0.0
OLLQ2ES(3,JLEV,JOBS) = 0.0
ENDIF
ENDDO
ENDDO
endif
c
RETURN
END