source: LMDZ5/trunk/libf/phymar/olwvn.F90 @ 2089

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