!*********************** SUBROUTINE LAYERAVG *************************

   SUBROUTINE LAYERAVG(LDGRADPS,PX1,PX2,PY2,KN1,KN2,KI,PZ,PZS,PZPS)

!-----------------------------------------------------------------------

!     This software was developed and tested by Y.J. Rochon
!     with contributions from L. Garand, D.S. Turner, and S. Polavarapu
!     of the Atmospheric Science and Technology Directorate,
!     Environment Canada (EC).

!     Copyright 2006, Environment Canada, All Rights Reserved.

!     Please send any improvements to any one of the above authors
!     at firstname.lastname@ec.gc.ca (e.g yves.rochon@ec.gc.ca) and provide
!     appropriate aknowledgement through referencing to the authors or
!     the corresponding journal article (see below).

!     Description:

!     Perform integration between points PX1(KI-1) and
!     PX1(KI+1) with  piecewise linear weighting having
!     weights of zero at  ki-1 and ki+1 and max weight at ki.

!     Method:
!     - Piecewise weighted interpolation in ln(P).
!     - Journal reference:
!       Rochon, Y.J., L. Garand, D.S. Turner, and S. Polavarapu.
!       Jacobian mapping between coordinate systems in data assimilation,
!       Q. J. of the Royal Met. Soc., Accepted pending revisions on 25
!       Sept. 2006.

!     History:

!     Version   Date        Comment
!     -------   ----        -------
!     1         10/2005     Original F77 code by Y.J. Rochon with
!                           contributions from S. Polavarapu. (EC)
!     2         10/2006     Adaptation for F90 and for improved consistency
!                           with RTTOV code format (Y.J. Rochon, EC).
!                           Argument names of original code were not changed.
!     
!     Arguments:
!     
!     Input

!     PX1(KN1).................Reference levels (e.g. lnP; in increasing values)
!     PX2(KN2).................Available levels (e.g. lnP; in increasing values)
!     PY2(KN2).................Values at PX2 levels (e.g. temperature)
!     LDGRADPS..................Flag indicating if gradient w.r.t. Ps is 
!                              required. True for yes.
!     PZS......................dlnP/dPs required when  LDGRADPS=.true.

!     KN1......................Dimension of PX1.
!     KN2......................Dimension of other arrays.
!     KI.......................Identifies region of interest: 
!                              PX1(KI-1) to PX1(KI+1)   
!     LDGRADPS..................Flag indicating of gradient w.r.t. Ps is 
!                              required. True for yes.
!     PZ.......................Extra array related to gradients w.r.t. Ps
!                              when LDGRADPS=.true.
!     PZS......................dlnP/dPs required when  LDGRADPS=.true.

!     Output

!     PZ(KN2)..................Resultant accumulated contribution factors
!                              (a row of the K matrix)
!     PZPS.....................Gradient term w.r.t. Ps when LDGRADPS=.true.
!                              (extra element to the row of the K matrix)

!     External functions and subroutines:
!     
!     LAYERAVG: Performs integration between points ZLNPO(JO-1) and
!               ZLNPO(JO+1) with  piecewise linear weighting having
!               weights of zero at  JO-1 and JO+1 and max weight at JO.

!     Related routines: INTAVGAD, INTAVG, INTAVGTL, INTAVGK, SUBLAYER

!     Assumptions:

!     1) PX1(i)<PX1(i+1) & PX2(i)<PX2(i+1)

!     Comments:
!                    
!     1) The gradient calc w.r.t Ps does not account for possible
!     re-assigment of lowest contributing RTM level in INTAVG* and LAYERAVG
!     to the surface model level when the original values are below
!     the model surface. This will result in differences from gradients
!     calculated using finite differences.

!--------------------------------------------------------------------
!     
      USE PARKIND1  ,ONLY : JPIM     ,JPRB
      USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

      IMPLICIT NONE
!     
! --- Subroutine arguments

      LOGICAL, INTENT(in) :: LDGRADPS                  
      INTEGER(KIND=JPIM), INTENT(in) :: KN1,KN2,KI
      REAL(KIND=JPRB), INTENT(in)    :: PX1(KN1),PX2(KN2),PY2(KN2),PZS(KN2)
      REAL(KIND=JPRB), INTENT(inout) :: PZ(KN2),PZPS
      REAL(KIND=JPRB)    :: ZHOOK_HANDLE
!                  
! --- Local scalars and arrays
!                          
      INTEGER(KIND=JPIM) :: J,IC,ISKIP
      REAL(KIND=JPRB)    :: Z1,Z2,Z3,ZW1,ZW2,ZSUM


#include "sublayer.h"
!-----------------------------------------------------------------------
      IF (LHOOK) CALL DR_HOOK('LAYERAVG',0,ZHOOK_HANDLE)

! --- Identify boundary points

      z2=px1(ki)

      if (ki == 1) then 
         z1=2.0*z2-px1(ki+1)
      else
         z1=px1(ki-1)
      endif   

      if (ki == kn1) then
         z3=2.0*z2-z1
      else   
         z3=px1(ki+1)
      endif
      if (z3 > px2(kn2)) z3=px2(kn2)

      iskip=0
      if (z2 >= px2(kn2)) then
         z3=px2(kn2)
         z2=px2(kn2)
         iskip=1
      endif

! --- Determine forward interpolator (kflag=0) or TLM (kflag>0)

      pzps=0.0
      pz(1:kn2)=0.0
      ic=0
      do j=1,kn2-1
         if (px2(j) >= z3) go to 1000

         if (px2(j) <= z2.and.px2(j+1) > z1) then 

            call sublayer(z1,z2,z3,px2(j),px2(j+1),ldgradps, &
                      &    py2(j),py2(j+1),zw1,zw2,          &
                      &    pzs(j),pzs(j+1),pzps)
            pz(j)=pz(j)+zw1
            pz(j+1)=pz(j+1)+zw2
            ic=1
         endif

         if (px2(j) < z3.and.px2(j+1) >= z2.and.iskip == 0) then

            call sublayer(z3,z2,z1,px2(j),px2(j+1),ldgradps, &
                      &    py2(j),py2(j+1),zw1,zw2,          &
                      &    pzs(j),pzs(j+1),pzps)
            pz(j)=pz(j)+zw1
            pz(j+1)=pz(j+1)+zw2
            ic=1
         endif
      enddo
      j=kn2
 1000 continue
      if (ic == 0) pz(j)=1.0

!     Normalize sum to unity (instead of calculating and dividing by
!     weighting denominator)

      zsum=sum(pz(1:kn2))
      pz(1:kn2)=pz(1:kn2)/zsum
      if (ic /= 0) pzps=pzps/zsum

   IF (LHOOK) CALL DR_HOOK('LAYERAVG',1,ZHOOK_HANDLE)
   END SUBROUTINE LAYERAVG
