!  Differentiation of trunca_gems in forward (tangent) mode:
!   variations  of output variables: pcoeff pbetal phasef
!   with respect to input variables: phasef

SUBROUTINE TRUNCA_GEMS_TL(phasef, phasefd, prmu, pga, ppl, pbetal, &
&  pbetald, pcoeff, pcoeffd)

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

USE rt6svalues

 IMPLICIT NONE

! LOOP ON LEVELS
!****TRUNCA****DECOMPOSITION OF THE AEROSOL PHASE FUNCTION IN SERIES OF LEGENDRE POLYNOMIAL 
!              USED IN OS.f AND ISO.f

! THE TRUNCATUR METHOD CONSISTS IN DEFINING THE PHASE FUNCTION CORRESPONDING TO A COSENUS OF GAUSSIAN
! ANGLE OF 0.8 & 0.94. FROM THIS TWO POINTS THE PHASE FUNCTION OF MU=0 IS EXTRAPOLATED. THE TRUNCATUR
! COEFFICIENT (COEFF) IS DETERMINED ACCORDING TO THE PHASE FUNCTION THAT IS NOT ABOVE OR HIGHER THAN THE 
! EXTRAPOLATED VALUE.

!     INTERFACE
!     ---------
! TRUNCA IS CALLED BY DISCOM  

!     INPUTS
!     ------

! PHASEF(KNT,KNBMU)     : Aerosol phase function profile.
! PRMU(KNANG)           : GAUSSIAN ANGLES FOR TRUNCATION OF PHASE FUNCTION 
! PGA(KNANG)            : GAUSSIAN WEIGHTS FOR TRUNCATION OF PHASE FUNCTION
! PPL(KNBMU,-1:KNANG+1) : USED IN TRUNCATION OF PHASE FUNCTION

!     OUTPUTS
!     -------

! PCOEFF(KNT)         : TRUNCATION COEFFICIENT
! PBETAL(KNT,KNANG+1) : COEFFICIENTS OF LEGENDRE POLYNOM

!     EXTERNALS.
!     ----------

!     MODIFICATIONS.
!     -------------
!          N.HUNEEUS 02.05.2007

!     SOURCE
!     ------
! ADAPTED FROM TRUNCA.f FROM ORIGINAL 6S CODE, SEE VERMOTE ET AL. (1997)

!     MODEL PARAMETERS
!     ----------------
!--------------------------------------------------------------------------------------
!INTEGER(KIND=JPIM), PARAMETER :: KNT=20, KNBMU=83, KNANG=80
  REAL(KIND=JPRB), INTENT(INOUT) :: phasef(0:knt, knbmu)
  REAL(KIND=JPRB), INTENT(INOUT) :: phasefd(0:knt, knbmu)
  REAL(KIND=JPRB), INTENT(IN) :: prmu(knbmu), pga(knbmu)
  REAL(KIND=JPRB), INTENT(IN) :: ppl(knbmu, -1:knang+1)
  REAL(KIND=JPRB), INTENT(OUT) :: pbetal(0:knt, 0:knang), pcoeff(0:knt)
  REAL(KIND=JPRB), INTENT(OUT) :: pbetald(0:knt, 0:knang), pcoeffd(0:&
&  knt)
! LOCAL VARIABLE
! --------------
  INTEGER(KIND=JPIM) :: ind(1), j, j1, jk, jkk, jang, jlev
  REAL(KIND=JPRB) :: zaa, z1, z2, za, zz1, zrm, z
  REAL(KIND=JPRB) :: zaad, z1d, zad, zz1d, zd
  REAL(KIND=JPRB) :: zphase(knbmu), zaux1(knbmu), zaux2(knbmu)
  REAL(KIND=JPRB) :: zphased(knbmu)
  INTRINSIC MAXLOC
  INTRINSIC DBLE
  INTRINSIC DLOG10
  INTRINSIC ACOS

  REAL(KIND=JPRB) :: ZHOOK_HANDLE

  IF (LHOOK) CALL DR_HOOK('TRUNCA_GEMS_TL',0,ZHOOK_HANDLE)

  zaux1(:) = 0.0_JPRB
  zaux2(:) = 0.0_JPRB
  pbetald(:, :) = 0._JPRB
  pbetal(:, :) = 0.0_JPRB
  pcoeffd(0:knt) = 0._JPRB
  pbetald(0:knt, 0:knang) = 0._JPRB
  zphased(1:knbmu) = 0._JPRB
  DO jlev=0,knt
    DO jang=1,knbmu
      zphased(jang) = phasefd(jlev, jang)
      zphase(jang) = phasef(jlev, jang)
    ENDDO
    WHERE (prmu  >   0.8_JPRB) zaux1 = 1.0_JPRB
    ind = MAXLOC(zaux1)
    jk = ind(1) - 2
    WHERE (prmu  >   0.94) zaux2 = 1.0_JPRB
    ind = MAXLOC(zaux2)
    jkk = ind(1) - 2
! DEFINING THE SLOPE
    zaad = (phasefd(jlev, jkk)/(phasef(jlev, jkk)*LOG(10._JPRB))-phasefd(&
&      jlev, jk)/(phasef(jlev, jk)*LOG(10._JPRB)))/(ACOS(prmu(jkk))-ACOS(&
&      prmu(jk)))
    zaa = (LOG10(phasef(jlev, jkk))-LOG10(phasef(jlev, jk)))/(ACOS(&
&      prmu(jkk))-ACOS(prmu(jk)))
    z1d = phasefd(jlev, jkk)/(phasef(jlev, jkk)*LOG(10._JPRB))
    z1 = LOG10(phasef(jlev, jkk))
    z2 = ACOS(prmu(jkk))
! RECALCULATING THE PHASE FUNCTION FOR ANGLES CLOSE TO 0 OR WITH A COSENUS BIGGER THAN 0.94  
    DO j=jkk+1,knbmu
      zad = z1d + (ACOS(prmu(j))-z2)*zaad
      za = z1 + zaa*(ACOS(prmu(j))-z2)
      zphased(j) = 10.0_JPRB**za*LOG(10.0_JPRB)*zad
      zphase(j) = 10.0_JPRB**za
    ENDDO
    DO j=1,knbmu
      phasefd(jlev, j) = zphased(j)
      phasef(jlev, j) = zphase(j)
    ENDDO
! INITIALIZING BETAL
    DO j=0,knang
      pbetald(jlev, j) = 0._JPRB
      pbetal(jlev, j) = 0.0_JPRB
    ENDDO
! CALCULATING BETAL
    DO j=1,knbmu
      zd = pga(j)*phasefd(jlev, j)
      z = phasef(jlev, j)*pga(j)
      zrm = prmu(j)
      DO j1=0,knang
        pbetald(jlev, j1) = pbetald(jlev, j1) + ppl(j, j1)*zd
        pbetal(jlev, j1) = pbetal(jlev, j1) + z*ppl(j, j1)
      ENDDO
    ENDDO
    DO j=0,knang
      pbetald(jlev, j) = (2.0_JPRB*DBLE(j)+1.0_JPRB)*0.5_JPRB*pbetald(jlev, j)
      pbetal(jlev, j) = (2.0_JPRB*DBLE(j)+1.0_JPRB)*0.5_JPRB*pbetal(jlev, j)
    ENDDO
    zz1d = pbetald(jlev, 0)
    zz1 = pbetal(jlev, 0)
    pcoeffd(jlev) = -zz1d
    pcoeff(jlev) = 1.0_JPRB - zz1
    DO j=0,knang
      pbetald(jlev, j) = (pbetald(jlev, j)*zz1-pbetal(jlev, j)*zz1d)/zz1&
&        **2
      pbetal(jlev, j) = pbetal(jlev, j)/zz1
    ENDDO
  ENDDO
 
 IF (LHOOK) CALL DR_HOOK('TRUNCA_GEMS_TL',1,ZHOOK_HANDLE)
END SUBROUTINE TRUNCA_GEMS_TL
