source: LMDZ6/branches/Optimisation_LMDZ/libf/phylmd/rrtm/lwvd.F90 @ 3758

SUBROUTINE LWVD &
 & ( KIDIA,  KFDIA, KLON , KLEV  , KTRAER,&
 & PABCU,  PDBDT,&
 & PGA  ,  PGB,&
 & PCNTRB, PDISD, PDISU, PDWFSU &
 & )  

!**** *LWVD*   - L.W., VERTICAL INTEGRATION, DISTANT LAYERS

!     PURPOSE.
!     --------
!           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS

!**   INTERFACE.
!     ----------

!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===
! PABCU  : (KLON,NUA,3*KLEV+1) ; ABSORBER AMOUNTS
! PDBDT  : (KLON,KLEV)         ; LAYER PLANCK FUNCTION GRADIENT
! PGA, PGB                     ; PADE APPROXIMANTS
!     ==== OUTPUTS ===
! PCNTRB : (KLON,KLEV+1,KLEV+1); ENERGY EXCHANGE MATRIX
! PDIS.. : (KLON,KLEV+1)       ; CONTRIBUTION BY DISTANT LAYERS
! PDWFSU : (KLON,NSIL)         ; SPECTRAL DOWNWARD FLUX AT SURFACE

!        IMPLICIT ARGUMENTS :   NONE
!        --------------------

!     METHOD.
!     -------

!          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
!     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE

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

!          *LWTT*

!     REFERENCE.
!     ----------

!        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS

!     AUTHOR.
!     -------
!        JEAN-JACQUES MORCRETTE  *ECMWF*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 89-07-14
!        JJ Morcrette 97-04-18 Revised continuum + Surf. Emissiv.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!-----------------------------------------------------------------------

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

USE YOELW    , ONLY : NSIL     ,NIPD     ,NTRA     ,NUA      ,NG1P1

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KTRAER 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PABCU(KLON,NUA,3*KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDBDT(KLON,NSIL,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGA(KLON,NIPD,2,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGB(KLON,NIPD,2,KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCNTRB(KLON,KLEV+1,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDISD(KLON,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDISU(KLON,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PDWFSU(KLON,NSIL) 
!-----------------------------------------------------------------------

!*       0.1   ARGUMENTS
!              ---------

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

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

REAL(KIND=JPRB) :: ZTT(KLON,NTRA), ZTT1(KLON,NTRA), ZTT2(KLON,NTRA)

INTEGER(KIND=JPIM) :: IJKL, IKD1, IKD2, IKJ, IKJP1, IKM1, IKN,&
 & IKP1, IKU1, IKU2, ITT, JA, JK, JKJ, JL, JLK  

REAL(KIND=JPRB) :: ZWW, ZWW1, ZWW2, ZWW3, ZWW4, ZWW5, ZWW6
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "lwttm.intfb.h"

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

!*         1.    INITIALIZATION
!                --------------

!*         1.1     INITIALIZE LAYER CONTRIBUTIONS
!                  ------------------------------

IF (LHOOK) CALL DR_HOOK('LWVD',0,ZHOOK_HANDLE)
DO JK = 1, KLEV+1
  DO JL = KIDIA,KFDIA
    PDISD(JL,JK) = 0.0_JPRB
    PDISU(JL,JK) = 0.0_JPRB
  ENDDO
ENDDO

!*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
!                  ---------------------------------

DO JA = 1, NTRA
  DO JL = KIDIA,KFDIA
    ZTT (JL,JA) = 1.0_JPRB
    ZTT1(JL,JA) = 1.0_JPRB
    ZTT2(JL,JA) = 1.0_JPRB
  ENDDO
ENDDO

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

!*         2.      VERTICAL INTEGRATION
!                  --------------------

!*         2.2     CONTRIBUTION FROM DISTANT LAYERS
!                  ---------------------------------

!*         2.2.1   DISTANT AND ABOVE LAYERS
!                  ------------------------

!*         2.2.2   FIRST UPPER LEVEL
!                  -----------------

DO JK = 1 , KLEV-1
  IKP1=JK+1
  IKN=(JK-1)*NG1P1+1
  IKD1= JK  *NG1P1+1

  CALL LWTTM &
   & ( KIDIA         , KFDIA          , KLON,&
   & PGA(1,1,1,JK) , PGB(1,1,1,JK),&
   & PABCU(1,1,IKN), PABCU(1,1,IKD1), ZTT1 &
   & )  

!*         2.2.3   HIGHER UP
!                  ---------

  ITT=1
  DO JKJ=IKP1,KLEV
    IF(ITT == 1) THEN
      ITT=2
    ELSE
      ITT=1
    ENDIF
    IKJP1=JKJ+1
    IKD2= JKJ  *NG1P1+1

    IF(ITT == 1) THEN
      CALL LWTTM &
       & ( KIDIA         , KFDIA          , KLON,&
       & PGA(1,1,1,JKJ), PGB(1,1,1,JKJ),&
       & PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT1 &
       & )  

    ELSE
      CALL LWTTM &
       & ( KIDIA         , KFDIA          , KLON,&
       & PGA(1,1,1,JKJ), PGB(1,1,1,JKJ),&
       & PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT2 &
       & )  

    ENDIF

    DO JA = 1, KTRAER
      DO JL = KIDIA,KFDIA
        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5_JPRB
      ENDDO
    ENDDO

    DO JL = KIDIA,KFDIA
      ZWW1=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
      ZWW2=PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
      ZWW3=PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
      ZWW4=PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
      ZWW5=PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
      ZWW6=PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
      ZWW=ZWW1+ZWW2+ZWW3+ZWW4+ZWW5+ZWW6
      PDISD(JL,JK)=PDISD(JL,JK)+ZWW
      PCNTRB(JL,JK,IKJP1)=ZWW
      IF (JK == 1) THEN
        PDWFSU(JL,1)=PDWFSU(JL,1)+ZWW1
        PDWFSU(JL,2)=PDWFSU(JL,2)+ZWW2
        PDWFSU(JL,3)=PDWFSU(JL,3)+ZWW3
        PDWFSU(JL,4)=PDWFSU(JL,4)+ZWW4
        PDWFSU(JL,5)=PDWFSU(JL,5)+ZWW5
        PDWFSU(JL,6)=PDWFSU(JL,6)+ZWW6
      ENDIF
    ENDDO

  ENDDO
ENDDO

!*         2.2.4   DISTANT AND BELOW LAYERS
!                  ------------------------

!*         2.2.5   FIRST LOWER LEVEL
!                  -----------------

DO JK=3,KLEV+1
  IKN=(JK-1)*NG1P1+1
  IKM1=JK-1
  IKJ=JK-2
  IKU1= IKJ  *NG1P1+1

  CALL LWTTM &
   & ( KIDIA          , KFDIA         , KLON,&
   & PGA(1,1,1,IKJ) , PGB(1,1,1,IKJ),&
   & PABCU(1,1,IKU1), PABCU(1,1,IKN), ZTT1 &
   & )  

!*         2.2.6   DOWN BELOW
!                  ----------

  ITT=1
  DO JLK=1,IKJ
    IF(ITT == 1) THEN
      ITT=2
    ELSE
      ITT=1
    ENDIF
    IJKL=IKM1-JLK
    IKU2=(IJKL-1)*NG1P1+1

    IF(ITT == 1) THEN
      CALL LWTTM &
       & ( KIDIA          , KFDIA          , KLON,&
       & PGA(1,1,1,IJKL), PGB(1,1,1,IJKL),&
       & PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT1 &
       & )  

    ELSE
      CALL LWTTM &
       & ( KIDIA          , KFDIA          , KLON,&
       & PGA(1,1,1,IJKL), PGB(1,1,1,IJKL),&
       & PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT2 &
       & )  

    ENDIF

    DO JA = 1, KTRAER
      DO JL = KIDIA,KFDIA
        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5_JPRB
      ENDDO
    ENDDO

    DO JL = KIDIA,KFDIA
      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)&
       & +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)&
       & +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)&
       & +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)&
       & +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)&
       & +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)  
      PDISU(JL,JK)=PDISU(JL,JK)+ZWW
      PCNTRB(JL,JK,IJKL)=ZWW
    ENDDO

  ENDDO
ENDDO

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

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