olwvn.F90

Go to the documentation of this file.

SUBROUTINE olwvn ( KIDIA,KFDIA,KLON,KLEV,KUAER &
     &  , pabcu,pdbsl,pga,pgb &
     &  , padjd,padju,pcntrb,pdbdt )
!
!**** *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
!
!        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
!-----------------------------------------------------------------------
!      IMPLICIT LOGICAL (L)
!
!#include "yomcst.h"
!#include "yoerad.h"
!#include "yoeaer.h"
!#include "yoelw.h"
!#include "yoesw.h"
!#include "yoerdu.h"


#include "tsmbkind.h"

USE yoeolw   , ONLY : nisp     ,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,nisp,klev*2) &
     &  , pga(klon,8,2,klev) , pgb(klon,8,2,klev)
!
real_b :: padjd(klon,klev+1), padju(klon,klev+1) &
     &  ,  pcntrb(klon,klev+1,klev+1) &
     &  ,  pdbdt(klon,nisp,klev)
!
!-----------------------------------------------------------------------
!
!*       0.2   LOCAL ARRAYS
!              ------------
!
integer_m :: itx(klon)
!
real_b :: zglayd(klon),zglayu(klon) &
     &  ,  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) = 0.
    padju(jl,jk) = 0.
  END DO
END DO
!
!*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
!                  ---------------------------------
!
DO ja = 1 , ntra
  DO jl = kidia,kfdia
    ztt(jl,ja) = 1.0
    ztt1(jl,ja) = 1.0
    ztt2(jl,ja) = 1.0
  END DO
END DO
!
DO ja = 1 , nua
  DO jl = kidia,kfdia
    zuu(jl,ja) = 0.
 END DO
END DO
!
!     ------------------------------------------------------------------
!
!*         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 jl = kidia,kfdia
    zglayd(jl) = 0.
    zglayu(jl) = 0.
  END DO
!
  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)
      END DO
    END DO
!
!
    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)
      zglayd(jl)=zglayd(jl)+zwtr*wg1(jg)
    END DO
!
!*         2.1.2   DOWNWARD LAYERS
!                  ---------------
!
    imu = ixu + jg
    DO ja = 1 , kuaer
      DO jl = kidia,kfdia
        zuu(jl,ja) = pabcu(jl,ja,imu) - pabcu(jl,ja,inu)
      END DO
    END DO
!
!
    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) 
      zglayu(jl)=zglayu(jl)+zwtr*wg1(jg)
    END DO
!
  END DO
!
  DO jl = kidia,kfdia
    padjd(jl,jk) = zglayd(jl)
    pcntrb(jl,jk,jk+1) = zglayd(jl)
    padju(jl,jk+1) = zglayu(jl)
    pcntrb(jl,jk+1,jk) = zglayu(jl)
    pcntrb(jl,jk  ,jk) = 0.0
  END DO
!
END DO
!
DO jk = 1 , klev
  jk2 = 2 * jk
  jk1 = jk2 - 1
  DO jnu = 1 , nisp
    DO jl = kidia,kfdia
      pdbdt(jl,jnu,jk) = pdbsl(jl,jnu,jk1) + pdbsl(jl,jnu,jk2)
    END DO
  END DO
END DO
!
RETURN
END SUBROUTINE olwvn