lwvd.F90

Go to the documentation of this file.

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