lwvb.F90

Go to the documentation of this file.

SUBROUTINE lwvb &
  &( kidia , kfdia , klon  , klev  , kuaer &
  &, pabcu , padjd , padju &
  &, pb    , pbint , pbsur , pbtop &
  &, pdisd , pdisu , pemis , pemiw &
  &, pgasur, pgbsur, pgatop, pgbtop &
  &, pdwfsu,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,NSIL,KLEV+1); SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
! PBINT  : (KLON,KLEV+1)     ; HALF-LEVEL PLANCK FUNCTIONS
! PBSUR  : (KLON,NSIL)       ; SPECTRAL SURFACE PLANCK FUNCTION
! PBTOP  : (KLON,NSIL)       ; SPECTRAL T.O.A. PLANCK FUNCTION
! PDIS.. : (KLON,KLEV+1)     ; CONTRIBUTION BY DISTANT LAYERS
! PEMIS  : (KLON)            ; SURFACE LW EMISSIVITY
! PEMIW  : (KLON)            ; SURFACE LW WINDOW EMISSIVITY
! PGASUR, PGBSUR             ; SURFACE PADE APPROXIMANTS
! PGATOP, PGBTOP             ; T.O.A. PADE APPROXIMANTS 
!     ==== OUTPUTS ===
! PDWFSU : (KLON,NSIL)       ; SPECTRAL DOWNWARD FLUX AT SURFACE
! PFLUC(KLON,2,KLEV)         ; RADIATIVE FLUXES CLEAR-SKY:
!                     1  ==>  UPWARD   FLUX TOTAL

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

!     METHOD.
!     -------

!          COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
!     ATMOSPHERE AND 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
!        JJ Morcrette 96-06-07  Surface LW Window Emissivity

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

#include "tsmbkind.h"

USE yoelw    , ONLY : nsil     ,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,nsil,klev+1),pbint(klon,klev+1)&
  &,  pbsur(klon,nsil)   , pbtop(klon,nsil)&
  &,  pdisd(klon,klev+1) , pdisu(klon,klev+1)&
  &,  pemis(klon)        , pemiw(klon)&
  &,  pgasur(klon,nipd,2), pgbsur(klon,nipd,2)&
  &,  pgatop(klon,nipd,2), pgbtop(klon,nipd,2)

real_b :: pdwfsu(klon,nsil)  , pfluc(klon,2,klev+1)

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

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

real_b :: zbsur(klon,nsil)&
  &,  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

!     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)=_one_
    ztt1(jl,ja)=_one_
    ztt2(jl,ja)=_one_
  ENDDO
ENDDO

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

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

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


!*         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)
    ENDDO
  ENDDO


  CALL lwtt &
   &( kidia        , kfdia        , klon &
   &, pgatop(1,1,1), pgbtop(1,1,1)&
   &, zuu          , ztt &
   &)

  DO jl = kidia,kfdia
    zcntop1=pbtop(jl,1)*ztt(jl,1)          *ztt(jl,10)
    zcntop2=pbtop(jl,2)*ztt(jl,2)*ztt(jl,7)*ztt(jl,11)
    zcntop3=pbtop(jl,3)*ztt(jl,4)*ztt(jl,8)*ztt(jl,12)
    zcntop4=pbtop(jl,4)*ztt(jl,5)*ztt(jl,9)*ztt(jl,13)
    zcntop5=pbtop(jl,5)*ztt(jl,3)          *ztt(jl,14)
    zcntop6=pbtop(jl,6)*ztt(jl,6)          *ztt(jl,15)
    zcntop(jl)=zcntop1+zcntop2+zcntop3+zcntop4+zcntop5+zcntop6
    pfluc(jl,2,jk)=zcntop(jl)-pbint(jl,jk)-pdisd(jl,jk)-padjd(jl,jk)
    IF (jk == 1) THEN
      pdwfsu(jl,1)=zcntop1-pb(jl,1,jk)-pdwfsu(jl,1)
      pdwfsu(jl,2)=zcntop2-pb(jl,2,jk)-pdwfsu(jl,2)
      pdwfsu(jl,3)=zcntop3-pb(jl,3,jk)-pdwfsu(jl,3)
      pdwfsu(jl,4)=zcntop4-pb(jl,4,jk)-pdwfsu(jl,4)
      pdwfsu(jl,5)=zcntop5-pb(jl,5,jk)-pdwfsu(jl,5)
      pdwfsu(jl,6)=zcntop6-pb(jl,6,jk)-pdwfsu(jl,6)
    ENDIF
  ENDDO

ENDDO

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)
  pfluc(jl,2,jk)=zcntop(jl)-pbint(jl,jk)-pdisd(jl,jk)-padjd(jl,jk)
ENDDO


!*         2.5     EXCHANGE WITH LOWER LIMIT
!                  -------------------------

jk = 1
in=(jk-1)*ng1p1+1

DO jl = kidia,kfdia
  zbsur(jl,1)=pbsur(jl,1)*pemis(jl) -(_one_-pemis(jl))*pdwfsu(jl,1)
  zbsur(jl,2)=pbsur(jl,2)*pemis(jl) -(_one_-pemis(jl))*pdwfsu(jl,2)
  zbsur(jl,3)=pbsur(jl,3)*pemiw(jl) -(_one_-pemiw(jl))*pdwfsu(jl,3)
  zbsur(jl,4)=pbsur(jl,4)*pemiw(jl) -(_one_-pemiw(jl))*pdwfsu(jl,4)
  zbsur(jl,5)=pbsur(jl,5)*pemis(jl) -(_one_-pemis(jl))*pdwfsu(jl,5)
  zbsur(jl,6)=pbsur(jl,6)*pemis(jl) -(_one_-pemis(jl))*pdwfsu(jl,6)

  pfluc(jl,1,jk) = zbsur(jl,1)&
   &+ zbsur(jl,2)&
   &+ zbsur(jl,3)&
   &+ zbsur(jl,4)&
   &+ zbsur(jl,5)&
   &+ zbsur(jl,6)

  zbsur(jl,1)=zbsur(jl,1)-pb(jl,1,1)
  zbsur(jl,2)=zbsur(jl,2)-pb(jl,2,1)
  zbsur(jl,3)=zbsur(jl,3)-pb(jl,3,1)
  zbsur(jl,4)=zbsur(jl,4)-pb(jl,4,1)
  zbsur(jl,5)=zbsur(jl,5)-pb(jl,5,1)
  zbsur(jl,6)=zbsur(jl,6)-pb(jl,6,1)
ENDDO

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)
    ENDDO
  ENDDO


  CALL lwtt &
   &( kidia        , kfdia        , klon &
   &, pgasur(1,1,1), pgbsur(1,1,1)&
   &, zuu, ztt &
   &)

  DO jl = kidia,kfdia
    zcnsol(jl)=zbsur(jl,1)*ztt(jl,1)          *ztt(jl,10)&
     &+zbsur(jl,2)*ztt(jl,2)*ztt(jl,7)*ztt(jl,11)&
     &+zbsur(jl,3)*ztt(jl,4)*ztt(jl,8)*ztt(jl,12)&
     &+zbsur(jl,4)*ztt(jl,5)*ztt(jl,9)*ztt(jl,13)&
     &+zbsur(jl,5)*ztt(jl,3)          *ztt(jl,14)&
     &+zbsur(jl,6)*ztt(jl,6)          *ztt(jl,15)
    pfluc(jl,1,jk)=zcnsol(jl)+pbint(jl,jk)-pdisu(jl,jk)-padju(jl,jk)
  ENDDO

ENDDO

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

RETURN
END SUBROUTINE lwvb