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.
!-----------------------------------------------------------------------

#include "tsmbkind.h"

USE yoelw    , ONLY : nsil     ,nipd     ,ntra     ,nua      ,&
            &ng1      ,ng1p1    ,wg1


IMPLICIT NONE


!     DUMMY INTEGER SCALARS
integer_m :: kfdia
integer_m :: kidia
integer_m :: klev
integer_m :: klon
integer_m :: kuaer



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

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


real_b :: pabcu(klon,nua,3*klev+1)&
  &,  pdbsl(klon,nsil,klev*2)&
  &,  pga(klon,nipd,2,klev)   , pgb(klon,nipd,2,klev)

real_b :: padjd(klon,klev+1)      , padju(klon,klev+1)&
  &,  pcntrb(klon,klev+1,klev+1)&
  &,  pdbdt(klon,nsil,klev)   , pdwfsu(klon,nsil)

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

!*       0.2   LOCAL ARRAYS
!              ------------

real_b :: ztt(klon,ntra), ztt1(klon,ntra), ztt2(klon,ntra),  zuu(klon,nua)

!     LOCAL INTEGER SCALARS
integer_m :: ibs, idd, im12, imu, ind, inu, ixd, ixu,&
             &ja, jg, jk, jk1, jk2, jl, jnu

!     LOCAL REAL SCALARS
real_b :: zwtr, zwtr1, zwtr2, zwtr3, zwtr4, zwtr5, zwtr6


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

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

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

DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    padjd(jl,jk) = _zero_
    padju(jl,jk) = _zero_
  ENDDO
ENDDO

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

DO ja = 1 , ntra
  DO jl = kidia,kfdia
    ztt(jl,ja) = _one_
    ztt1(jl,ja) = _one_
    ztt2(jl,ja) = _one_
  ENDDO
ENDDO

DO ja = 1 , nua
  DO jl = kidia,kfdia
    zuu(jl,ja) = _zero_
  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) = _zero_
  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

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

RETURN
END SUBROUTINE lwvn