olwb.F90

Go to the documentation of this file.

SUBROUTINE olwb &
     &  ( kidia, kfdia, klon  , klev  &
     &  , pdt0 , pt   , pth &
     &  , pb   , pbint, pbsuin, pbsur , pbtop , pdbsl &
     &  , pga  , pgb  , pgasur, pgbsur, pgatop, pgbtop )
!
!**** *LWB*   - COMPUTES BLACK-BODY FUNCTIONS FOR LONGWAVE CALCULATIONS
!
!     PURPOSE.
!     --------
!           COMPUTES PLANCK FUNCTIONS
!
!**   INTERFACE.
!     ----------
!
!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===
! PDT0   : (KLON)             ; SURFACE TEMPERATURE DISCONTINUITY
! PT     : (KLON,KLEV)        ; TEMPERATURE
! PTH    : (KLON,KLEV+1)      ; HALF LEVEL TEMPERATURE
!     ==== OUTPUTS ===
! PB     : (KLON,NISP,KLEV+1) ; SPECTRAL HALF LEVEL PLANCK FUNCTION
! PBINT  : (KLON,KLEV+1)      ; HALF LEVEL PLANCK FUNCTION
! PBSUIN : (KLON)             ; SURFACE PLANCK FUNCTION
! PBSUR  : (KLON,NISP)        ; SURFACE SPECTRAL PLANCK FUNCTION
! PBTOP  : (KLON,NISP)        ; TOP SPECTRAL PLANCK FUNCTION
! PDBSL  : (KLON,NISP,KLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
! PGA    : (KLON,8,2,KLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
! PGB    : (KLON,8,2,KLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
! PGASUR, PGBSUR (KLON,8,2)   ; SURFACE PADE APPROXIMANTS
! PGATOP, PGBTOP (KLON,8,2)   ; T.O.A. PADE APPROXIMANTS
!
!        IMPLICIT ARGUMENTS :   NONE
!        --------------------
!
!     METHOD.
!     -------
!
!          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
!     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
!
!     EXTERNALS.
!     ----------
!
!          NONE
!
!     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 : mxixt    ,nisp     ,nipd     ,  ga     ,&
            & gb     ,tintp    ,tstand   ,tstp     ,xp

IMPLICIT NONE


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

!-----------------------------------------------------------------------
!
!*       0.1   ARGUMENTS
!              ---------
!
real_b :: pdt0(klon), pt(klon,klev), pth(klon,klev+1)
!
real_b :: pb(klon,nisp,klev+1), pbint(klon,klev+1) &
     &  ,  pbsuin(klon)       , pbsur(klon,nisp) &
     &  ,  pbtop(klon,nisp)   , pdbsl(klon,nisp,klev*2) &
     &  ,  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)
!
!-------------------------------------------------------------------------
!
!*       0.2   LOCAL ARRAYS
!              ------------
integer_m :: indb(klon),inds(klon)

real_b :: zblay(klon,klev),zblev(klon,klev+1) &
     &  , zres(klon),zres2(klon),zti(klon),zti2(klon)
     
real_b :: zdst1, zdsto1, zdstx, zdstox
     
integer_m :: ilev2, indsu, indt, indtp, indto, inus, inue, ixtox, ixtx &
     &  , jf, jg, jnu, jk, jk1, jk2, jl, ikl
!
!     ------------------------------------------------------------------
!
!
!*         1.0     PLANCK FUNCTIONS AND GRADIENTS
!                  ------------------------------
!
ilev2=2*klev
inus=1
inue=nisp
       
DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    pbint(jl,jk) = 0.
  END DO
END DO
DO jnu=1,nisp
  DO jl=kidia,kfdia
    pbsur(jl,jnu)=0.
    pbtop(jl,jnu)=0.
  END DO
  DO jk=1,klev
    DO jl=kidia,kfdia
      pb(jl,jnu,jk)=0.
    END DO
  END DO
  DO jk=1,ilev2
    DO jl=kidia,kfdia
      pdbsl(jl,jnu,jk)=0.
    END DO  
  END DO
END DO
DO jl = kidia,kfdia
  pbsuin(jl) = 0.
END DO
!
DO jnu=inus,inue
!
!
!*         1.1   LEVELS FROM SURFACE TO KLEV
!                ----------------------------
!                TEMPERATURE ENTERED FROM TOP TO BOTTOM
!
  DO jk = 1 , klev
    ikl=klev+1-jk
    DO jl = kidia,kfdia
      zti(jl)=(pth(jl,ikl+1)-tstand)/tstand
      zres(jl) = xp(1,jnu)+zti(jl)*(xp(2,jnu)+zti(jl)*(xp(3,jnu) &
      &       +zti(jl)*(xp(4,jnu)+zti(jl)*(xp(5,jnu)+zti(jl)*(xp(6,jnu) &
      &       )))))
      pbint(jl,jk)=pbint(jl,jk)+zres(jl)
      pb(jl,jnu,jk)= zres(jl)
      zblev(jl,jk) = zres(jl)
      
      zti2(jl)=(pt(jl,ikl)-tstand)/tstand
      zres2(jl)=xp(1,jnu)+zti2(jl)*(xp(2,jnu)+zti2(jl)*(xp(3,jnu) &
      &     +zti2(jl)*(xp(4,jnu)+zti2(jl)*(xp(5,jnu)+zti2(jl)*(xp(6,jnu) &
      &       )))))
      zblay(jl,jk) = zres2(jl)
    END DO
  END DO
!
!
!*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
!                ---------------------------------
!                TEMPERATURE ENTERED FROM TOP TO BOTTOM
!
  DO jl = kidia,kfdia
    zti(jl)=(pth(jl,1)-tstand)/tstand
    zti2(jl) = (pth(jl,klev+1) + pdt0(jl) - tstand) / tstand
    zres(jl) = xp(1,jnu)+zti(jl)*(xp(2,jnu)+zti(jl)*(xp(3,jnu) &
    &   +zti(jl)*(xp(4,jnu)+zti(jl)*(xp(5,jnu)+zti(jl)*(xp(6,jnu) &
    &      )))))
    zres2(jl) = xp(1,jnu)+zti2(jl)*(xp(2,jnu)+zti2(jl)*(xp(3,jnu) &
    &    +zti2(jl)*(xp(4,jnu)+zti2(jl)*(xp(5,jnu)+zti2(jl)*(xp(6,jnu) &
    &       )))))
    pbint(jl,klev+1) = pbint(jl,klev+1)+zres(jl)
    pb(jl,jnu,klev+1)= zres(jl)
    zblev(jl,klev+1) = zres(jl)
    pbtop(jl,jnu) = zres(jl)
    pbsur(jl,jnu) = zres2(jl)
    pbsuin(jl) = pbsuin(jl) + zres2(jl)
  END DO
!
!
!*         1.3   GRADIENTS IN SUB-LAYERS
!                -----------------------
!
  DO jk = 1 , klev
    jk2 = 2 * jk
    jk1 = jk2 - 1
    DO jl = kidia,kfdia
      pdbsl(jl,jnu,jk1) = zblay(jl,jk  ) - zblev(jl,jk)
      pdbsl(jl,jnu,jk2) = zblev(jl,jk+1) - zblay(jl,jk)
    END DO
  END DO
!
END DO
!
!*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
!                ---------------------------------------------
!
DO jl=kidia,kfdia
  zdsto1 = (pth(jl,1)-tintp(1)) / tstp
  ixtox = max( 1, min( int(mxixt), int( zdsto1 + 1. ) ) )
  zdstox = (pth(jl,1)-tintp(ixtox))/tstp
  IF (zdstox.LT.0.5) THEN
    indto=ixtox
  ELSE
    indto=ixtox+1
  END IF
  indb(jl)=indto
  
  zdst1 = (pth(jl,klev+1)-tintp(1)) / tstp
  ixtx = max( 1, min( int(mxixt), int( zdst1 + 1. ) ) )
  zdstx = (pth(jl,klev+1)-tintp(ixtx))/tstp
  IF (zdstx.LT.0.5) THEN
    indt=ixtx
  ELSE
    indt=ixtx+1
  END IF
  inds(jl)=indt
END DO
!
DO jf=1,2
  DO jg=1, 8
    DO jl=kidia,kfdia
      indsu=inds(jl)
      pgasur(jl,jg,jf)=ga(indsu,2*jg-1,jf)
      pgbsur(jl,jg,jf)=gb(indsu,2*jg-1,jf)
      indtp=indb(jl)
      pgatop(jl,jg,jf)=ga(indtp,2*jg-1,jf)
      pgbtop(jl,jg,jf)=gb(indtp,2*jg-1,jf)
    END DO
  END DO
END DO
!
DO jk=1,klev
  ikl=klev+1-jk
  DO jl=kidia,kfdia
    zdst1 = (pt(jl,ikl)-tintp(1)) / tstp
    ixtx = max( 1, min( int(mxixt), int( zdst1 + 1. ) ) )
    zdstx = (pt(jl,ikl)-tintp(ixtx))/tstp
    IF (zdstx.LT.0.5) THEN
      indt=ixtx
    ELSE
      indt=ixtx+1
    END IF
    indb(jl)=indt
  END DO
!
  DO jf=1,2
    DO jg=1, 8
      DO jl=kidia,kfdia
        indt=indb(jl)
        pga(jl,jg,jf,jk)=ga(indt,2*jg,jf)
        pgb(jl,jg,jf,jk)=gb(indt,2*jg,jf)
      END DO
    END DO
  END DO
END DO
!
!     ------------------------------------------------------------------
!
RETURN
END SUBROUTINE olwb