lwvn.F90

Go to the documentation of this file.

SUBROUTINE lwvn &
 & ( kidia, kfdia, klon  , klev , kuaer,&
 & pabcu, pdbsl, pga   , pgb,&
 & padjd, padju, pcntrb, pdbdt, pdwfsu &
 & )  

!**** *LWVN*   - L.W., VERTICAL INTEGRATION, NEARBY LAYERS

!     PURPOSE.
!     --------
!           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
!           TO GIVE LONGWAVE FLUXES OR RADIANCES

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

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

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

!     METHOD.
!     -------

!          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
!     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE

!     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      ,&
 & ng1      ,ng1p1    ,wg1  

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)    :: KUAER 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PABCU(klon,nua,3*klev+1) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDBSL(klon,nsil,klev*2) 
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)   :: PADJD(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PADJU(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCNTRB(klon,klev+1,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDBDT(klon,nsil,klev) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PDWFSU(klon,nsil) 
!-----------------------------------------------------------------------

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

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

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

REAL(KIND=JPRB) :: ZTT(klon,ntra), ZTT1(klon,ntra), ZTT2(klon,ntra),  ZUU(klon,nua)

INTEGER(KIND=JPIM) :: IBS, IDD, IM12, IMU, IND, INU, IXD, IXU,&
 & JA, JG, JK, JK1, JK2, JL, JNU  

REAL(KIND=JPRB) :: ZWTR, ZWTR1, ZWTR2, ZWTR3, ZWTR4, ZWTR5, ZWTR6
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "lwtt.intfb.h"

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

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

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

IF (lhook) CALL dr_hook('LWVN',0,zhook_handle)
DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    padjd(jl,jk) = 0.0_jprb
    padju(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

DO ja = 1 , nua
  DO jl = kidia,kfdia
    zuu(jl,ja) = 0.0_jprb
  ENDDO
ENDDO

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

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

!*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
!                  ---------------------------------

DO jk = 1 , klev

!*         2.1.1   DOWNWARD LAYERS
!                  ---------------

  im12 = 2 * (jk - 1)
  ind = (jk - 1) * ng1p1 + 1
  ixd = ind
  inu = jk * ng1p1 + 1
  ixu = ind

  DO jg = 1 , ng1
    ibs = im12 + jg
    idd = ixd + jg

    DO ja = 1 , kuaer
      DO jl = kidia,kfdia
        zuu(jl,ja) = pabcu(jl,ja,ind) - pabcu(jl,ja,idd)
      ENDDO
    ENDDO

    CALL lwtt &
     & ( kidia        , kfdia        , klon,&
     & pga(1,1,1,jk), pgb(1,1,1,jk),&
     & zuu          , ztt &
     & )  

    DO jl = kidia,kfdia
      zwtr1=pdbsl(jl,1,ibs)*ztt(jl,1)          *ztt(jl,10)
      zwtr2=pdbsl(jl,2,ibs)*ztt(jl,2)*ztt(jl,7)*ztt(jl,11)
      zwtr3=pdbsl(jl,3,ibs)*ztt(jl,4)*ztt(jl,8)*ztt(jl,12)
      zwtr4=pdbsl(jl,4,ibs)*ztt(jl,5)*ztt(jl,9)*ztt(jl,13)
      zwtr5=pdbsl(jl,5,ibs)*ztt(jl,3)          *ztt(jl,14)
      zwtr6=pdbsl(jl,6,ibs)*ztt(jl,6)          *ztt(jl,15)
      zwtr=zwtr1+zwtr2+zwtr3+zwtr4+zwtr5+zwtr6
      padjd(jl,jk) = padjd(jl,jk) + zwtr * wg1(jg)
      IF (jk == 1) THEN
        pdwfsu(jl,1)=pdwfsu(jl,1)+wg1(jg)*zwtr1
        pdwfsu(jl,2)=pdwfsu(jl,2)+wg1(jg)*zwtr2
        pdwfsu(jl,3)=pdwfsu(jl,3)+wg1(jg)*zwtr3
        pdwfsu(jl,4)=pdwfsu(jl,4)+wg1(jg)*zwtr4
        pdwfsu(jl,5)=pdwfsu(jl,5)+wg1(jg)*zwtr5
        pdwfsu(jl,6)=pdwfsu(jl,6)+wg1(jg)*zwtr6
      ENDIF
    ENDDO

!*         2.1.2   UPWARD LAYERS
!                  -------------

    imu = ixu + jg
    DO ja = 1 , kuaer
      DO jl = kidia,kfdia
        zuu(jl,ja) = pabcu(jl,ja,imu) - pabcu(jl,ja,inu)
      ENDDO
    ENDDO

    CALL lwtt &
     & ( kidia        , kfdia        , klon,&
     & pga(1,1,1,jk), pgb(1,1,1,jk),&
     & zuu          , ztt &
     & )  

    DO jl = kidia,kfdia
      zwtr=pdbsl(jl,1,ibs)*ztt(jl,1)          *ztt(jl,10)&
       & +pdbsl(jl,2,ibs)*ztt(jl,2)*ztt(jl,7)*ztt(jl,11)&
       & +pdbsl(jl,3,ibs)*ztt(jl,4)*ztt(jl,8)*ztt(jl,12)&
       & +pdbsl(jl,4,ibs)*ztt(jl,5)*ztt(jl,9)*ztt(jl,13)&
       & +pdbsl(jl,5,ibs)*ztt(jl,3)          *ztt(jl,14)&
       & +pdbsl(jl,6,ibs)*ztt(jl,6)          *ztt(jl,15)  
      padju(jl,jk+1) = padju(jl,jk+1) + zwtr * wg1(jg)
    ENDDO

  ENDDO

  DO jl = kidia,kfdia
    pcntrb(jl,jk,jk+1) = padjd(jl,jk)
    pcntrb(jl,jk+1,jk) = padju(jl,jk+1)
    pcntrb(jl,jk  ,jk) = 0.0_jprb
  ENDDO

ENDDO

DO jk = 1 , klev
  jk2 = 2 * jk
  jk1 = jk2 - 1

  DO jnu = 1 , nsil
    DO jl = kidia,kfdia
      pdbdt(jl,jnu,jk) = pdbsl(jl,jnu,jk1) + pdbsl(jl,jnu,jk2)
    ENDDO
  ENDDO
ENDDO

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

IF (lhook) CALL dr_hook('LWVN',1,zhook_handle)
END SUBROUTINE lwvn