SUBROUTINE TRUNCA_GEMS(PHASEF,PRMU,PGA,PPL,         &
&                               PBETAL, PCOEFF)

!****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
!          A.BENEDETTI -ECMWF 06.08.2008

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

!     MODEL PARAMETERS
!     ----------------
!--------------------------------------------------------------------------------------

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

USE RT6SVALUES

IMPLICIT NONE

!INTEGER(KIND=JPIM)(KIND=JPIM), PARAMETER :: KNT=20, KNBMU=83, KNANG=80

REAL(KIND=JPRB),INTENT(INOUT)  :: PHASEF(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)

! 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) :: ZPHASE(KNBMU), ZAUX1(KNBMU), ZAUX2(KNBMU)

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

ZAUX1(:)=0.0_JPRB
ZAUX2(:)=0.0_JPRB
PBETAL(:,:)=0.0_JPRB

DO JLEV=0,KNT
  
  DO JANG=1,KNBMU
    ZPHASE(JANG)=PHASEF(JLEV,JANG)
  ENDDO

! FINDING FIRST POINT FOR THE EXTRAPOLATION
  WHERE(PRMU >  0.8_JPRB) ZAUX1=1.0_JPRB
  IND=MAXLOC(ZAUX1)
  JK=IND(1)-2
! FINDING SECOND POINT FOR THE EXTRAPOLATION
  WHERE(PRMU >  0.94) ZAUX2=1.0_JPRB
  IND=MAXLOC(ZAUX2)
  JKK=IND(1)-2
! DEFINING THE SLOPE
  ZAA=(LOG10(PHASEF(JLEV,JKK))-LOG10(PHASEF(JLEV,JK)))/(ACOS(PRMU(JKK))-ACOS(PRMU(JK)))
  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
    ZA=Z1+ZAA*(ACOS(PRMU(J))-Z2)
    ZPHASE(J)=10.0_JPRB**ZA
  ENDDO
  DO J=1,KNBMU
    PHASEF(JLEV,J)=ZPHASE(J)
  ENDDO
! INITIALIZING BETAL
  DO J=0,KNANG
    PBETAL(JLEV,J)=0.0_JPRB
  ENDDO
! CALCULATING BETAL
  DO J=1,KNBMU
    Z=PHASEF(JLEV,J)*PGA(J)
    ZRM=PRMU(J)
    DO J1=0,KNANG
      PBETAL(JLEV,J1)=PBETAL(JLEV,J1)+Z*PPL(J,J1)
    ENDDO
  ENDDO
  DO J=0,KNANG
    PBETAL(JLEV,J)=(2.0_JPRB*DBLE(J)+1.0_JPRB)*0.5_JPRB*PBETAL(JLEV,J)
  ENDDO
  ZZ1=PBETAL(JLEV,0)
  PCOEFF(JLEV)=1.0_JPRB-ZZ1
  DO J=0,KNANG
    PBETAL(JLEV,J)=PBETAL(JLEV,J)/ZZ1
  ENDDO
ENDDO ! LOOP ON LEVELS

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