SUBROUTINE CH_VPROF(KFLAG1,KFLAG2,PINDEX,KNUM,KNLEV, 4
& PRESS,PRESSA,PIN,POUT,KMOD,KDIM,KKERN)
C
IMPLICIT NONE
INTEGER KNUM,KNLEV,KFLAG1(KNUM),KFLAG2(KNUM),KMOD,KKERN,KDIM
REAL*8 PRESS(KNUM),PIN(KDIM),POUT(KDIM)
REAL PINDEX(KNUM)
REAL*8 PRESSA(KNLEV)
C
#if defined (DOC)
*
*
**s/r CH_LVPROF - Apply forward/TLM model or its adjoint for profile of point
* values.
*
* Forward model: piecewise linear vertical interpolation.
*
*
* AUTHOR: Y. Rochon *ARQX/MSC July 2005
*
* REVISIONS:
*
* PURPOSE: - Apply forward/TLM model or its adjoint for profile of point values.
* Forward model: piecewise linear vertical interpolation.
*
* ARGUMENTS
*
* INPUT:
*
* KFLAG1.......Flags (1 for valid obs data)
* KFLAG2.......Flags (0 for data in vertical range)
* PINDEX.......Array of indices of analysis upper levels closest
* obs levels.
* KNLEV........Number of analyis levels
* KNUM.........Number of obs levels
* PRESS........Obs levels
* PRESSA.......Analysis levels (in increasing size)
* PIN..........Input background/increment values at analysis levels
* POUT.........Initial GOMOBS segment when KMOD=1
* kmod........ Flag indicating purpose of call:
* 0: Use as forward or TLM model
* 1: Use as adjoint of TLM model.
* kkern.......Use of averaging kernel.
* 0 for no, position index for yes
* kdim........dimension >= max(knum,knlev)
*
* OUTPUT:
*
* POUT.........Output background/increment values at obs levels
* when KMOD=0.
* Updated GOMOBS segment when KMOD=1.
* KFLAG2.......Flags modified to 1 or 2 if point above or below
* analysis region.
*
*
*COMMENT
*
*
* 1) ZDAPPS contribution when obs is T or wind for both 'BG' and 'HR'
* is not included in this version.
*
************************************************************************
#endif
C
C* Global variables
C
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comchem.cdk"
#include "commatrix.cdk"
C
INTEGER J,IK1,J1
REAL*8 ZWB,ZWT
REAL*8 zh(knum,knlev)
integer IKINDEX(knum)
C
zh(:,:)=0.0
ikindex(:)=0
C
C Determine interpolation weights
C
DO J=1,KNUM
C
C Check for levels which extend above the top analysis level
C or are entirely below surface.
C
if (KFLAG1(J).EQ.1.AND.KFLAG2(J).EQ.0) then
if (PRESS(J).lt.PRESSA(1)) then
kflag2(j)=1
else if (PRESS(J).gt.PRESSA(KNLEV)) then
kflag2(j)=2
end if
end if
C
IF ((KFLAG1(J).EQ.1.AND.KFLAG2(J).EQ.0).or.KKERN.gt.0) THEN
C
C Apply vertical linear interpolation to obs location
C
IK1 = PINDEX(J)
C
C Make sure obs level is in between analysis
C levels IK1 and IK1+1.
C
C This is to account for any inconsistency in
C vertical coordinate transformation which
C might occur in processing when input
C obs vertical coordinate is not pressure.
C
if (PRESS(J).LT.PRESSA(ik1)) then
IK1 = IK1 - 1
IF (IK1.LT.1) IK1=1
endif
if (PRESS(J).GT.PRESSA(ik1+1)) then
IK1 = IK1 + 1
IF (IK1.GT.KNLEV-1) IK1=KNLEV-1
endif
IKINDEX(J)=IK1
ZWB = LOG(press(j)/pressa(ik1))
& /LOG(pressa(ik1+1)/pressa(ik1))
ZWT = 1.0D0 - ZWB
c
c zpresbpt = ((vhybinc(ik1) - rptopinc/rprefinc)
c & /(1.0-rptopinc/rprefinc))**rcoefinc
c zpresbpb = ((vhybinc(ik1+1) - rptopinc/rprefinc)
c & /(1.0-rptopinc/rprefinc))**rcoefinc
c ZDADPS = ( (ZPRESBPT/pressa(ik1))*LOG(ZLEV/pressa(ik1+1))
c + -(ZPRESBPB/pressa(ik1+1))*LOG(ZLEV/pressa(ik1)) )
c + /LOG(ZPB/ZPT)**2
C
if (kkern.gt.0) then
C
C Incorporate averaging kernels
C
do j1=1,knum
zh(j1,ik1+1)=zh(j1,ik1+1)+ZWB*ravgkern(j1,j,kkern)
zh(j1,ik1)=zh(j1,ik1)+ZWT*ravgkern(j1,j,kkern)
end do
else
zh(j,ik1+1)=ZWB
zh(j,ik1)=ZWT
end if
END IF
END DO
C
C Apply interpolation weights
C
IF (kkern.gt.0) then
C
C Case with averaging kernel
C
IF (KMOD.EQ.0) THEN
C
C Forward model calc.
C
POUT(:)=0.0
DO J=1,KNUM
IF (KFLAG1(J).EQ.1.AND.KFLAG2(J).EQ.0)
& POUT(J)=dot_product(PIN(1:knlev),ZH(J,:))
END DO
C
ELSE IF (KMOD.EQ.1) THEN
C
C Adjoint of forward/TLM model calc.
C
DO J=1,KNUM
IF (KFLAG1(J).EQ.1.AND.KFLAG2(J).EQ.0)
& POUT(1:KNLEV)=POUT(1:KNLEV)+zh(J,:)*PIN(J)
END DO
END IF
ELSE
IF (KMOD.EQ.0) THEN
C
C Forward model calc.
C
POUT(:)=0.0
DO J=1,KNUM
IF (KFLAG1(J).EQ.1.AND.KFLAG2(J).EQ.0) THEN
IK1=IKINDEX(J)
POUT(J) = zh(J,IK1+1)*PIN(IK1+1) + zh(J,IK1)*PIN(IK1)
END IF
END DO
C
ELSE IF (KMOD.EQ.1) THEN
C
C Adjoint of forward/TLM model calc.
C
DO J=1,KNUM
IF (KFLAG1(J).EQ.1.AND.KFLAG2(J).EQ.0) THEN
IK1=IKINDEX(J)
POUT(IK1)=POUT(IK1)+zh(J,IK1)*PIN(J)
POUT(IK1+1)=POUT(IK1+1)+zh(J,IK1+1)*PIN(J)
END IF
END DO
END IF
END IF
C
RETURN
END