SUBROUTINE oda_HTpp(CDFAM)
      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