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
!        M.Hamrud      01-Oct-2003 CY28 Cleaning

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

USE parkind1  ,ONLY : jpim     ,jprb
USE yomhook   ,ONLY : lhook,   dr_hook

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMODE 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDT0(klon) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAVE(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTL(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PB(klon,nsil,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBINT(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBSUR(klon,nsil) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBTOP(klon,nsil) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDBSL(klon,nsil,klev*2) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGA(klon,nipd,2,klev) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGB(klon,nipd,2,klev) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGASUR(klon,nipd,2) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGBSUR(klon,nipd,2) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGATOP(klon,nipd,2) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PGBTOP(klon,nipd,2) 
!-----------------------------------------------------------------------

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

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

!              ------------
INTEGER(KIND=JPIM) :: INDB(klon)   , INDS(klon)
REAL(KIND=JPRB) :: ZBLAY(klon,klev), ZBLEV(klon,klev+1)&
 & ,  ZRES(KLON)      , ZRES2(KLON)&
 & ,  ZTI(KLON)       , ZTI2(KLON)  

INTEGER(KIND=JPIM) :: ILEV2, INDSU, INDT, INDTO, INDTP, INUE, INUS,&
 & IXTOX, IXTX, JF, JG, JK, JK1, JK2, JL, JNU  

REAL(KIND=JPRB) :: ZDST1, ZDSTO1, ZDSTOX, ZDSTX
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

print *,'dans LWB'
IF (lhook) CALL dr_hook('LWB',0,zhook_handle)
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) = 0.0_jprb
  ENDDO
ENDDO

DO jnu=1,nsil
  DO jl=kidia,kfdia
    pbsur(jl,jnu)=0.0_jprb
    pbtop(jl,jnu)=0.0_jprb
  ENDDO
  DO jk=1,klev
    DO jl=kidia,kfdia
      pb(jl,jnu,jk)=0.0_jprb
    ENDDO
  ENDDO
  DO jk=1,ilev2
    DO jl=kidia,kfdia
      pdbsl(jl,jnu,jk)=0.0_jprb
    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( mxixt, int( zdsto1 + 1.0_jprb ) ) )
  zdstox = (ptl(jl,klev+1)-tintp(ixtox))/tstp
  IF (zdstox < 0.5_jprb) THEN
    indto=ixtox
  ELSE
    indto=ixtox+1
  ENDIF
  indb(jl)=indto
  zdst1 = (ptl(jl,1)-tintp(1)) / tstp
  ixtx = max( 1, min( mxixt, int( zdst1 + 1.0_jprb ) ) )
  zdstx = (ptl(jl,1)-tintp(ixtx))/tstp
  IF (zdstx < 0.5_jprb) 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( mxixt, int( zdst1 + 1.0_jprb ) ) )
    zdstx = (ptave(jl,jk)-tintp(ixtx))/tstp
    IF (zdstx < 0.5_jprb) 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

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

IF (lhook) CALL dr_hook('LWB',1,zhook_handle)
END SUBROUTINE lwb