olwvb.F90

Go to the documentation of this file.

SUBROUTINE olwvb ( KIDIA,KFDIA,KLON,KLEV,KUAER &
     &  , pabcu,padjd,padju,pb,pbint,pbsui,pbsur,pbtop &
     &  , pdisd,pdisu,pemis &
     &  , pga,pgb,pgasur,pgbsur,pgatop,pgbtop &
     &  , pfluc )
!
!**** *LWVB*   - L.W., VERTICAL INTEGRATION, EXCHANGE WITH BOUNDARIES
!
!     PURPOSE.
!     --------
!           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
!           INTEGRATION
!
!**   INTERFACE.
!     ----------
!
!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===
! PABCU : (KLON,NUA,3*KLEV+1); ABSORBER AMOUNTS
! PADJ.. : (KLON,KLEV+1)     ; CONTRIBUTION BY ADJACENT LAYERS
! PB     : (KLON,NISP,KLEV+1); SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
! PBINT  : (KLON,KLEV+1)     ; HALF-LEVEL PLANCK FUNCTIONS
! PBSUI  : (KLON)            ; SURFACE PLANCK FUNCTION
! PBSUR  : (KLON,NISP)       ; SPECTRAL SURFACE PLANCK FUNCTION
! PBTOP  : (KLON,NISP)       ; SPECTRAL T.O.A. PLANCK FUNCTION
! PDIS.. : (KLON,KLEV+1)     ; CONTRIBUTION BY DISTANT LAYERS
! PEMIS  : (KLON)            ; SURFACE EMISSIVITY
! PGA, PGB                   ; PADE APPROXIMANTS
! PGASUR, PGBSUR             ; SURFACE PADE APPROXIMANTS
! PGATOP, PGBTOP             ; T.O.A. PADE APPROXIMANTS 
!     ==== OUTPUTS ===
! PFLUC(KLON,2,KLEV)         ; RADIATIVE FLUXES CLEAR-SKY:
!                     1  ==>  UPWARD   FLUX TOTAL
!
!        IMPLICIT ARGUMENTS :   NONE
!        --------------------
!
!     METHOD.
!     -------
!
!          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
!     ATMOSPHERE
!          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
!     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
!          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
!
!     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
!-----------------------------------------------------------------------

#include "tsmbkind.h"

USE yoeolw   , ONLY : nisp     ,nipd     ,ntra     ,nua      ,ng1p1


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) &
     &  ,  padjd(klon,klev+1), padju(klon,klev+1) &
     &  ,  pb(klon,nisp,klev+1), pbint(klon,klev+1) &
     &  ,  pbsur(klon,nisp), pbsui(klon), pbtop(klon,nisp) &
     &  ,  pdisd(klon,klev+1), pdisu(klon,klev+1) &
     &  ,  pemis(klon) &
     &  ,  pga(klon,8,2,klev), pgb(klon,8,2,klev) &
     &  ,  pgasur(klon,8,2), pgbsur(klon,8,2) &
     &  ,  pgatop(klon,8,2), pgbtop(klon,8,2)
!
real_b :: pfluc(klon,2,klev+1) 
!
!-----------------------------------------------------------------------
!
!*       0.2   LOCAL ARRAYS
!              ------------
!
integer_m :: itx(klon)
!
real_b :: zbgnd(klon), zfd(klon), zfdn(klon,klev+1) &
     &  ,  zfn10(klon), zfu(klon), zfup(klon,klev+1) &
     &  ,  ztt(klon,ntra), ztt1(klon,ntra), ztt2(klon,ntra) &
     &  ,  zuu(klon,nua) , zcnsol(klon), zcntop(klon)
!

!     LOCAL INTEGER SCALARS
integer_m :: in, ja, jk, jl, ind1, ind2, ind3, ind4, jlim

!     LOCAL REAL SCALARS
real_b :: zcntop1, zcntop2, zcntop3, zcntop4, zcntop5, zcntop6

!-----------------------------------------------------------------------
!
!*         1.    INITIALIZATION
!                --------------
!
!
!*         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)=1.0
  END DO
END DO
!
!     ------------------------------------------------------------------
!
!*         2.      VERTICAL INTEGRATION
!                  --------------------
!
ind1=0
ind3=0
ind4=1
ind2=1
!
!
!*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
!                  -----------------------------------
!
DO jk = 1 , klev
  in=(jk-1)*ng1p1+1
!
  DO ja=1,kuaer
    DO jl=kidia,kfdia
      zuu(jl,ja)=pabcu(jl,ja,in)
    END DO
  END DO
!
!
  CALL lwtt ( kidia,kfdia,klon &
     &          , pgatop(1,1,1), pgbtop(1,1,1), zuu, ztt )
!
  DO jl = kidia,kfdia
    zcntop(jl)=pbtop(jl,1)*ztt(jl,1)          *ztt(jl,10) &
    &      +pbtop(jl,2)*ztt(jl,2)*ztt(jl,7)*ztt(jl,11) &
    &      +pbtop(jl,3)*ztt(jl,4)*ztt(jl,8)*ztt(jl,12) &
    &      +pbtop(jl,4)*ztt(jl,5)*ztt(jl,9)*ztt(jl,13) &
    &      +pbtop(jl,5)*ztt(jl,3)          *ztt(jl,14) &
    &      +pbtop(jl,6)*ztt(jl,6)          *ztt(jl,15)
    zfd(jl)=zcntop(jl)-pbint(jl,jk)-pdisd(jl,jk)-padjd(jl,jk)
    zfdn(jl,jk)=zfd(jl)
    pfluc(jl,2,jk)=zfd(jl)
  END DO
!
END DO
!
jk = klev+1
in=(jk-1)*ng1p1+1
!
DO jl = kidia,kfdia
  zcntop(jl)= pbtop(jl,1) &
  &   + pbtop(jl,2) &
  &   + pbtop(jl,3) &
  &   + pbtop(jl,4) &
  &   + pbtop(jl,5) &
  &   + pbtop(jl,6)
  zfd(jl)=zcntop(jl)-pbint(jl,jk)-pdisd(jl,jk)-padjd(jl,jk)
  zfdn(jl,jk)=zfd(jl)
  pfluc(jl,2,jk)=zfd(jl)
END DO
!
!*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
!                  ---------------------------------------
!
!
!*         2.4.1   INITIALIZATION
!                  --------------
!
!
!*         2.5     EXCHANGE WITH LOWER LIMIT
!                  -------------------------
!
DO jl = kidia,kfdia
  zbgnd(jl)=pbsui(jl)*pemis(jl)-(1.-pemis(jl)) &
  &               *pfluc(jl,2,1)-pbint(jl,1)
END DO
!
jk = 1
in=(jk-1)*ng1p1+1
!
DO jl = kidia,kfdia
  zcnsol(jl)=pbsur(jl,1) &
  & +pbsur(jl,2) &
  & +pbsur(jl,3) &
  & +pbsur(jl,4) &
  & +pbsur(jl,5) &
  & +pbsur(jl,6)
  zcnsol(jl)=zcnsol(jl)*zbgnd(jl)/pbsui(jl)
  zfu(jl)=zcnsol(jl)+pbint(jl,jk)-pdisu(jl,jk)-padju(jl,jk)
  zfup(jl,jk)=zfu(jl)
  pfluc(jl,1,jk)=zfu(jl)
END DO
!
DO jk = 2 , klev+1
  in=(jk-1)*ng1p1+1
!
!
  DO ja=1,kuaer
    DO jl=kidia,kfdia
      zuu(jl,ja)=pabcu(jl,ja,1)-pabcu(jl,ja,in)
    END DO
  END DO
!
!
  CALL lwtt ( kidia,kfdia,klon &
     &          , pgasur(1,1,1), pgbsur(1,1,1), zuu, ztt )
!
  DO jl = kidia,kfdia
    zcnsol(jl)=pbsur(jl,1)*ztt(jl,1)          *ztt(jl,10) &
    &      +pbsur(jl,2)*ztt(jl,2)*ztt(jl,7)*ztt(jl,11) &
    &      +pbsur(jl,3)*ztt(jl,4)*ztt(jl,8)*ztt(jl,12) &
    &      +pbsur(jl,4)*ztt(jl,5)*ztt(jl,9)*ztt(jl,13) &
    &      +pbsur(jl,5)*ztt(jl,3)          *ztt(jl,14) &
    &      +pbsur(jl,6)*ztt(jl,6)          *ztt(jl,15)
    zcnsol(jl)=zcnsol(jl)*zbgnd(jl)/pbsui(jl)
    zfu(jl)=zcnsol(jl)+pbint(jl,jk)-pdisu(jl,jk)-padju(jl,jk)
    zfup(jl,jk)=zfu(jl)
    pfluc(jl,1,jk)=zfu(jl)
  END DO
!
!
END DO
!
!
!
!*         2.7     CLEAR-SKY FLUXES
!                  ----------------
!
DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    pfluc(jl,1,jk) = zfup(jl,jk)
    pfluc(jl,2,jk) = zfdn(jl,jk)
  END DO
END DO
!
!     ------------------------------------------------------------------
!
RETURN
END SUBROUTINE olwvb