lwb.F90

Go to the documentation of this file.

SUBROUTINE lwb &
 &( kidia, kfdia, klon  , klev  , kmode &
 &, pdt0 , ptave, ptl &
 &, pb   , pbint, 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
! PTAVE  : (KLON,KLEV)       ; TEMPERATURE
! PTL    : (KLON,KLEV+1)     ; HALF LEVEL TEMPERATURE
!     ==== OUTPUTS ===
! PB     : (KLON,NSIL,KLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
! PBINT  : (KLON,KLEV+1)     ; HALF LEVEL PLANCK FUNCTION
! PBSUR  : (KLON,NSIL)       ; SURFACE SPECTRAL PLANCK FUNCTION
! PBTOP  : (KLON,NSIL)       ; TOP SPECTRAL PLANCK FUNCTION
! PDBSL  : (KLON,NSIL,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
!        MODIFIED : 99-06-14  D.SALMOND  Optimisation

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

#include "tsmbkind.h"

USE yoelw    , ONLY : mxixt    ,nsil     ,nipd     ,pdga     ,&
            &pdgb     ,tintp    ,tstand   ,tstp     ,xp


IMPLICIT NONE


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



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

!*       0.1   ARGUMENTS
!              ---------

real_b :: pdt0(klon),ptave(klon,klev),ptl(klon,klev+1)

real_b :: pb(klon,nsil,klev+1)   , pbint(klon,klev+1)&
  &,  pbsur(klon,nsil)       ,  pbtop(klon,nsil)   &
  &,  pdbsl(klon,nsil,klev*2)&
  &,  pga(klon,nipd,2,klev)  , pgb(klon,nipd,2,klev)&
  &,  pgasur(klon,nipd,2)    , pgbsur(klon,nipd,2)&
  &,  pgatop(klon,nipd,2)    , pgbtop(klon,nipd,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)

!     LOCAL INTEGER SCALARS
integer_m :: ilev2, indsu, indt, indto, indtp, inue, inus,&
             &ixtox, ixtx, jf, jg, jk, jk1, jk2, jl, jnu

!     LOCAL REAL SCALARS
real_b :: zdst1, zdsto1, zdstox, zdstx


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


!*         1.0     PLANCK FUNCTIONS AND GRADIENTS
!                  ------------------------------

ilev2=2*klev
inus=1
inue=nsil
IF (kmode == 2) THEN
  inus=3
  inue=4
ENDIF

DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    pbint(jl,jk) = _zero_
  ENDDO
ENDDO

DO jnu=1,nsil
  DO jl=kidia,kfdia
    pbsur(jl,jnu)=_zero_
    pbtop(jl,jnu)=_zero_
  ENDDO
  DO jk=1,klev
    DO jl=kidia,kfdia
      pb(jl,jnu,jk)=_zero_
    ENDDO
  ENDDO
  DO jk=1,ilev2
    DO jl=kidia,kfdia
      pdbsl(jl,jnu,jk)=_zero_
    ENDDO
  ENDDO
ENDDO

DO jnu=inus,inue


!*         1.1   LEVELS FROM SURFACE TO KLEV
!                ----------------------------

  DO jk = 1 , klev
    DO jl = kidia,kfdia
      zti(jl)=(ptl(jl,jk)-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)=(ptave(jl,jk)-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)
    ENDDO
  ENDDO


!*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
!                ---------------------------------

  DO jl = kidia,kfdia
    zti(jl)=(ptl(jl,klev+1)-tstand)/tstand
    zti2(jl) = (ptl(jl,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)
  ENDDO


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

ENDDO

!*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
!                ---------------------------------------------

DO jl=kidia,kfdia
  zdsto1 = (ptl(jl,klev+1)-tintp(1)) / tstp
  ixtox = max( 1, min( int(mxixt), int( zdsto1 + _one_ ) ) )
  zdstox = (ptl(jl,klev+1)-tintp(ixtox))/tstp
  IF (zdstox < _half_) THEN
    indto=ixtox
  ELSE
    indto=ixtox+1
  ENDIF
  indb(jl)=indto
  zdst1 = (ptl(jl,1)-tintp(1)) / tstp
  ixtx = max( 1, min( int(mxixt), int( zdst1 + _one_ ) ) )
  zdstx = (ptl(jl,1)-tintp(ixtx))/tstp
  IF (zdstx < _half_) THEN
    indt=ixtx
  ELSE
    indt=ixtx+1
  ENDIF
  inds(jl)=indt
ENDDO

DO jf=1,2
  DO jg=1,nipd
    DO jl=kidia,kfdia
      indsu=inds(jl)
      pgasur(jl,jg,jf)=pdga(indsu,2*jg-1,jf)
      pgbsur(jl,jg,jf)=pdgb(indsu,2*jg-1,jf)
      indtp=indb(jl)
      pgatop(jl,jg,jf)=pdga(indtp,2*jg-1,jf)
      pgbtop(jl,jg,jf)=pdgb(indtp,2*jg-1,jf)
    ENDDO
  ENDDO
ENDDO


DO jk=1,klev
  DO jl=kidia,kfdia
    zdst1 = (ptave(jl,jk)-tintp(1)) / tstp
    ixtx = max( 1, min( int(mxixt), int( zdst1 + _one_ ) ) )
    zdstx = (ptave(jl,jk)-tintp(ixtx))/tstp
    IF (zdstx < _half_) THEN
      indt=ixtx
    ELSE
      indt=ixtx+1
    ENDIF
    indb(jl)=indt
  ENDDO

  DO jf=1,2
    DO jl=kidia,kfdia
      indt=indb(jl)
      DO jg=1,nipd
        pga(jl,jg,jf,jk)=pdga(indt,2*jg,jf)
        pgb(jl,jg,jf,jk)=pdgb(indt,2*jg,jf)
      ENDDO
    ENDDO
  ENDDO


ENDDO

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

RETURN
END SUBROUTINE lwb