!-------------------------------------- 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 oda_HTpp(CDFAM) 1,1
use modmask
, only : lmaskpp_in,lmaskpp_out
#if defined (DOC)
*
***s/r AOBSPPP - Adjoint of the "vertical" interpolation
* for "UPPER AIR" data files.
*
*
*
*Author : P. Koclas *CMC/AES April 1996
*Revision:
* P. Koclas *CMC/AES February 1995
* - Minor modifications
* - Allow for multiple data files.
* P. KoCLAS CMC/CMSV AUGUST 1998
* - ANALYSYS ON ETA COORDINATE
* C. Charette ARMA/AES NOV 1998
* - Extrapolation GZ below model orography.
* - Adapt code to follow Luc Fillion's notes on 3dvar-eta
* analysis. LLPRINT to print diagnostics
* C. Charette ARMA/AES JUN 2000
* - Added check on type of vertical coordinate
* MOBDATA(NCMVCO,)=2 --> PRESSURE COORDINATE
* C. Charette ARMA/SMC NOV. 2001
* - No extrapolation of uu,vv,tt,es
* C. Charette ARMA/SMC FEV. 2002
* - Commented out the if(llprint...) statements within
* the do loops. They were preventing vectorization.
* C. Charette - ARMA/SMC - Sept 2004
* - Conversion to hybrid vertical coordinate
* S. Pellerin - ARMA - Jan. 2009
* - Rename the subroutine acording to ODA naming convention
* - Use of NCMOMI as index of adjoint residual variable
* - Use of mask to process assimilated observation only
**
* -------------------
*
* Purpose: based on vint3d to build the adjoint of the
* vertical interpolation for UPPER-AIR data files.
*
*Arguments
*
* CDFAM: FAMILY OF OBSSERVATION
*
#endif
IMPLICIT NONE
CHARACTER *2 CDFAM
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comgem.cdk"
#include "comphy.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
*
INTEGER IPB,IPT, IDBURP, ITYP
REAL*8 ZRES,ZOER
REAL*8 ZWB,ZWT,zcon,zexp,zgamma,ZATV,ZTVG
REAL*8 ZLEV,ZPT,ZPB,ZDADPS,ZPRESBPB,ZPRESBPT
INTEGER IOBS,IPOS,IK,ISTRIDE,IBEGIN,ILAST
INTEGER J,JF,JDATA
LOGICAL LLOK, LLPRINT
C
C Temperature lapse rate for extrapolation of gz below model surface
C
LLPRINT = .FALSE.
ccc LLPRINT = .TRUE.
zgamma = 0.0065 / GRAV
zexp = RGASD*zgamma
C
C* 1. Fill in COMMVO by using the adjoint of the "vertical"
c interpolation
C . ---------------------------------------------------------------
c ----
C
C TO eliminate dependancies in vector loop, a stride
C is chosen so that the data in the inner loop always
C comes from different "oservations" of the CMA.
C ------------------------------------------------------
C stride = first odd number greater than the longest
C observation.
C
ISTRIDE=2*(NMAXLEN/2) + 1
C
C
C Process all data within the domain of the model
C
DO J=1,ISTRIDE
*vdir nodep
DO JDATA=J,ndata,ISTRIDE
IF (lmaskpp_in(jdata)) THEN
IOBS = MOBDATA(NCMOBS,JDATA)
IPOS = MOBDATA(NCMPOS,JDATA)
ZOER = ROBDATA8(NCMOER,JDATA)
ZRES = ROBDATA8(NCMOMI,JDATA)
ZLEV = ROBDATA8(NCMPPP,JDATA)
IDBURP = MOD(MOBHDR(NCMITY,IOBS),1000)
IK = ROBDATA(NCMLYR,JDATA)
IPT = IK + IPOS*NFLEV
IPB = IPT+1
ZPT = RPPOBS(IK,IOBS)
ZPB = RPPOBS(IK+1,IOBS)
ZWB = LOG(ZLEV/ZPT)/LOG(ZPB/ZPT)
ZWT = 1.0D0 - ZWB
c ROBDATA8(NCMOMN,JDATA) = ROBDATA8(NCMOMN,JDATA)
c & * ROBDATA8(NCMOMA,JDATA)
C
zpresbpt = ((vhybinc(ik) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
zpresbpb = ((vhybinc(ik+1) - rptopinc/rprefinc)
& /(1.0-rptopinc/rprefinc))**rcoefinc
ZDADPS = ( (ZPRESBPT/ZPT)*LOG(ZLEV/ZPB)
+ -(ZPRESBPB/ZPB)*LOG(ZLEV/ZPT) )
+ /LOG(ZPB/ZPT)**2
C
C Set ZDADPS to zero for HUMSAT (idtyp=158)
IF (IDBURP .EQ. 158) THEN
ZDADPS = 0.0
ENDIF
C
GOMOBS(IPB,IOBS) = GOMOBS(IPB,IOBS) + ZWB*ZRES
GOMOBS(IPT,IOBS) = GOMOBS(IPT,IOBS) + ZWT*ZRES
GOMPS(1,IOBS) = GOMPS(1,IOBS) +
+ (GOMOBSG(IPB,IOBS) - GOMOBSG(IPT,IOBS))
+ *ZDADPS*ZRES
elseif (lmaskpp_out(jdata)) THEN
IOBS = MOBDATA(NCMOBS,JDATA)
IPOS = MOBDATA(NCMPOS,JDATA)
ZOER = ROBDATA8(NCMOER,JDATA)
ZRES = ROBDATA8(NCMOMI,JDATA)
ZLEV = ROBDATA8(NCMPPP,JDATA)
IDBURP = MOD(MOBHDR(NCMITY,IOBS),1000)
IPT = NFLEV-1 + IPOS*NFLEV
IPB = IPT+1
c ROBDATA8(NCMOMN,JDATA) = ROBDATA8(NCMOMN,JDATA)
c & * ROBDATA8(NCMOMA,JDATA)
c
c-------------adjoint of TL of geopotential extrapolation below
c orography
c
zcon = (zlev/gompsg(1,iobs))**zexp
ZATV = ((1.0 - ZCON)/ZGAMMA)*ZRES
ZTVG = OLTV(1,NFLEV,IOBS)*GOMTG(NFLEV,IOBS)
gomps(1,iobs) = gomps(1,iobs)
& + RGASD*ZTVG*zcon*zres/gompsg(1,iobs)
gomt(nflev,iobs) = gomt(nflev,iobs)
& + OLTV(1,NFLEV,IOBS)*ZATV
gomq(nflev,iobs) = gomq(nflev,iobs)
& + OLTV(2,NFLEV,IOBS)*ZATV
ENDIF
END DO
END DO
RETURN
END