olwu.F90

Go to the documentation of this file.

SUBROUTINE olwu ( KIDIA, KFDIA, KLON, KLEV &
     &  ,  paer, pcco2, pdp, paph, pqof, pt, pview, pwv &
     &  ,  pabcu     )
!
!**** *LWU* - LONGWAVE EFFECTIVE ABSORBER AMOUNTS
!
!     PURPOSE.
!     --------
!           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
!           TEMPERATURE EFFECTS
!
!**   INTERFACE.
!     ----------
!
!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===
! PAER   : (KLON,6,KLEV)     ; OPTICAL THICKNESS OF THE AEROSOLS
! PCCO2  :                   ; CONCENTRATION IN CO2 (PA/PA)
! PAPH   : (KLON,KLEV+1)     ; HALF LEVEL PRESSURE
! PQOF   : (KLON,KLEV)       ; CONCENTRATION IN OZONE (PA/PA)
! PT     : (KLON,KLEV)       ; TEMPERATURE
! PWV    : (KLON,KLEV)       ; SPECIFIC HUMIDITY PA/PA
! PVIEW  : (KLON)            ; COSECANT OF VIEWING ANGLE
!     ==== OUTPUTS ===
! PABCU  :(KLON,NUA,3*KLEV+1); EFFECTIVE ABSORBER AMOUNTS
!
!        IMPLICIT ARGUMENTS :   NONE
!        --------------------
!
!     METHOD.
!     -------
!
!          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
!     ABSORBERS.
!
!     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 yomcst   , ONLY : rg
USE yoesw    , ONLY : raer
USE yoeolw   , ONLY : nisp     ,nua      ,ng1      ,ng1p1    ,&
            &at       ,bt       ,rt1      ,tref     ,oct      ,&
            &rvgco2   ,rvgh2o   ,rvgo3
USE yoerdi   , ONLY : rch4     ,rn2o     ,rcfc11   ,rcfc12
USE yoerdu   , ONLY : r10e     ,repsco   ,repscq
USE yoedbug  , ONLY : ldebug


IMPLICIT NONE

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

!     DUMMY REAL SCALARS
real_b :: pcco2

CHARACTER*3 CVAR


!-----------------------------------------------------------------------
!
!*       0.1   ARGUMENTS
!              ---------
!
real_b :: paer(klon,6,klev) , pdp(klon,klev) &
     &  ,  paph(klon,klev+1), pqof(klon,klev) &
     &  ,  pt(klon,klev), pview(klon),  pwv(klon,klev)
!
real_b :: pabcu(klon,nua,3*klev+1)
!
!-----------------------------------------------------------------------
!
!*       0.2   LOCAL ARRAYS
!              ------------
real_b :: zably(klon,7, 3*klev),  zduc(klon, 3*klev) &
     &  , zdpm(klon, 3*klev), zupm(klon, 3*klev)
real_b :: zphio(klon),zpsc2(klon),zpsc3(klon),zpsh1(klon) &
     &  ,  zpsh2(klon),zpsh3(klon),zpsh4(klon),zpsh5(klon) &
     &  ,  zpsh6(klon),zpsio(klon),ztcon(klon) &
     &  ,  zphm6(klon),zpsm6(klon),zphn6(klon),zpsn6(klon)
real_b :: zssig(klon,3*klev+1), ztavi(klon) &
     &  ,  zuaer(klon,6), zxoz(klon), zxwv(klon)
!

!     LOCAL INTEGER SCALARS
integer_m :: iae1, iae2, iae3, ic, iccc, icp1, ig1, ij, ijpn,&
             &ikip1, ikj, ikjp, ikjpn, ikjr, ikl, ipk, ja, jae, &
             &jk, jki, jkk, jl, jae1, jae2, jae3, jc, jcp1, jj, jjpn, &
             & jkj, jkjr, jkjp, jkip1, jkp1, jkjpn

!     LOCAL REAL SCALARS
real_b :: zalup, zcac8, zcah1, zcah2, zcah3, zcah4,&
          &zcah5, zcah6, zcbc8, zcbh1, zcbh2, zcbh3, &
          &zcbh4, zcbh5, zcbh6, zdiff, zdpmg, zdpmp0, &
          &zfppw, ztx, ztx2, zu6, zup, zupmco2, zupmg, &
          &zupmh2o, zupmo3, zzably

!
!-----------------------------------------------------------------------
!
!*         1.    INITIALIZATION
!                --------------
!
!-----------------------------------------------------------------------
!
!
!*         2.    PRESSURE OVER GAUSS SUB-LEVELS
!                ------------------------------
!
DO jl = kidia,kfdia
  zssig(jl, 1 ) = paph(jl,klev+1)
END DO
!
DO jk = 1 , klev
  jkj=(jk-1)*ng1p1+1
  jkjr = jkj
  jkjp = jkj + ng1p1
  ikl=klev+1-jk
  DO jl = kidia,kfdia
    zssig(jl,jkjp)=paph(jl,ikl)
  END DO
  DO ig1=1,ng1
    jkj=jkj+1
    DO jl = kidia,kfdia
      zssig(jl,jkj)= (zssig(jl,jkjr)+zssig(jl,jkjp))*0.5_jprb &
      &  + rt1(ig1) * (zssig(jl,jkjp) - zssig(jl,jkjr)) * 0.5_jprb
    END DO
  END DO
END DO
!
!-----------------------------------------------------------------------
!
!
!*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
!                --------------------------------------------------
!
DO jki=1,3*klev
  jkip1=jki+1
  DO jl = kidia,kfdia
    zupm(jl,jki)=(zssig(jl,jki)+zssig(jl,jkip1))*0.5_jprb
    zdpm(jl,jki)=(zssig(jl,jki)-zssig(jl,jkip1))/(10._jprb*rg)
  END DO
END DO
!
DO jk = 1 , klev
  jkp1=jk+1
  ikl = klev+1 - jk
  DO jl = kidia,kfdia
    zxwv(jl) = max(pwv(jl,ikl) , repscq )
    zxoz(jl) = max(pqof(jl,ikl) / pdp(jl,ikl) , repsco )
  END DO
  jkj=(jk-1)*ng1p1+1
  jkjpn=jkj+ng1
  DO jkk=jkj,jkjpn
    DO jl = kidia,kfdia
      zdpmg = zdpm(jl,jkk)
      zdpmp0 = zdpmg / 101325._jprb
      zupmg =   zupm(jl,jkk) * zdpmp0
      zupmco2 = ( zupm(jl,jkk) + rvgco2 ) * zdpmp0
      zupmh2o = ( zupm(jl,jkk) + rvgh2o ) * zdpmp0
      zupmo3  = ( zupm(jl,jkk) + rvgo3  ) * zdpmp0
      zduc(jl,jkk) = zdpmg
      zably(jl,6,jkk) = zxoz(jl) * zdpmg
      zably(jl,7,jkk) = zxoz(jl) * zupmo3
      zu6 = zxwv(jl) * zupmg
      zfppw = 1.6078_jprb * zxwv(jl) / (1._jprb+0.608_jprb*zxwv(jl))
      zably(jl,1,jkk) = zxwv(jl) * zupmh2o
      zably(jl,5,jkk) = zu6 * zfppw
      zably(jl,4,jkk) = zu6 * (1._jprb-zfppw)
      zably(jl,3,jkk) = pcco2 * zupmco2
      zably(jl,2,jkk) = pcco2 * zdpmg
    END DO
  END DO
END DO
!
!-----------------------------------------------------------------------
!
!
!*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
!                --------------------------------------------------
!
DO ja = 1, nua
  DO jl = kidia,kfdia
    pabcu(jl,ja,3*klev+1) = 0.
  END DO
END DO
!

DO jk = 1 , klev
  jj=(jk-1)*ng1p1+1
  jjpn=jj+ng1
  ikl=klev+1-jk
!
!
!*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
!               --------------------------------------------------
! --            NB: 'PAER' AEROSOLS ARE ENTERED FROM TOP TO BOTTOM
!
  jae1=3*klev+1-jj
  jae2=3*klev+1-(jj+1)
  jae3=3*klev+1-jjpn
  DO jae=1,5
    DO jl = kidia,kfdia
      zuaer(jl,jae) = (raer(jae,1)*paer(jl, 1, jk ) &
      &      +raer(jae,2)*paer(jl, 2, jk)+raer(jae,3)*paer(jl, 3, jk) &
      &      +raer(jae,4)*paer(jl, 4, jk)+raer(jae,5)*paer(jl, 5, jk)) &
      &      /(zduc(jl,jae1)+zduc(jl,jae2)+zduc(jl,jae3))
    END DO
  END DO
!
!
!*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
!               --------------------------------------------------
! --            NB: 'PT' TEMPERATURES ARE ENTERED FROM TOP TO BOTTOM
!
  DO jl = kidia,kfdia
  
    ztavi(jl)=pt(jl,jk)
    ztcon(jl)=exp(6.08_jprb*(296._jprb/ztavi(jl)-1._jprb))
    ztx=ztavi(jl)-tref
    ztx2=ztx*ztx
    zzably = zably(jl,3,jae1)+zably(jl,3,jae2)+zably(jl,3,jae3)
    zup=min( max( 0.5_jprb*r10e*log( zzably ) + 5._jprb, 0._jprb), 6.0_jprb)
    zcah1=at(1,1)+zup*(at(1,2)+zup*(at(1,3)))
    zcbh1=bt(1,1)+zup*(bt(1,2)+zup*(bt(1,3)))
    zpsh1(jl)=exp( zcah1 * ztx + zcbh1 * ztx2 )
    zcah2=at(2,1)+zup*(at(2,2)+zup*(at(2,3)))
    zcbh2=bt(2,1)+zup*(bt(2,2)+zup*(bt(2,3)))
    zpsh2(jl)=exp( zcah2 * ztx + zcbh2 * ztx2 )
    zcah3=at(3,1)+zup*(at(3,2)+zup*(at(3,3)))
    zcbh3=bt(3,1)+zup*(bt(3,2)+zup*(bt(3,3)))
    zpsh3(jl)=exp( zcah3 * ztx + zcbh3 * ztx2 )
    zcah4=at(4,1)+zup*(at(4,2)+zup*(at(4,3)))
    zcbh4=bt(4,1)+zup*(bt(4,2)+zup*(bt(4,3)))
    zpsh4(jl)=exp( zcah4 * ztx + zcbh4 * ztx2 )
    zcah5=at(5,1)+zup*(at(5,2)+zup*(at(5,3)))
    zcbh5=bt(5,1)+zup*(bt(5,2)+zup*(bt(5,3)))
    zpsh5(jl)=exp( zcah5 * ztx + zcbh5 * ztx2 )
    zcah6=at(6,1)+zup*(at(6,2)+zup*(at(6,3)))
    zcbh6=bt(6,1)+zup*(bt(6,2)+zup*(bt(6,3)))
    zpsh6(jl)=exp( zcah6 * ztx + zcbh6 * ztx2 )
    zphm6(jl)=exp(-5.81e-4_jprb * ztx - 1.13e-6 * ztx2 )
    zpsm6(jl)=exp(-5.57e-4_jprb * ztx - 3.30e-6 * ztx2 )
    zphn6(jl)=exp(-3.46e-5_jprb * ztx + 2.05e-7 * ztx2 )
    zpsn6(jl)=exp( 3.70e-3_jprb * ztx - 2.30e-6 * ztx2 )
  END DO
  
!
  DO jl = kidia,kfdia
  
    ztavi(jl)=pt(jl,jk)
    ztx=ztavi(jl)-tref
    ztx2=ztx*ztx
    zzably = zably(jl,5,jae1)+zably(jl,5,jae2)+zably(jl,5,jae3)
    zalup = r10e * log( zzably )
    zup   = max( 0.0_jprb , 5.0_jprb + 0.5_jprb * zalup )
    zpsc2(jl) = (ztavi(jl)/tref) ** zup
    zcac8=at(8,1)+zup*(at(8,2)+zup*(at(8,3)))
    zcbc8=bt(8,1)+zup*(bt(8,2)+zup*(bt(8,3)))
    zpsc3(jl)=exp( zcac8 * ztx + zcbc8 * ztx2 )
    zphio(jl) = exp( oct(1) * ztx + oct(2) * ztx2)
    zpsio(jl) = exp( 2.* (oct(3)*ztx+oct(4)*ztx2))
  END DO
  

  iccc=2
  
  DO jkk=jj,jjpn
    jc=3*klev+1-jkk
    jcp1=jc+1
    
    iccc=iccc+1
    
    DO jl = kidia,kfdia
      zdiff = pview(jl)
      pabcu(jl,10,jc)=pabcu(jl,10,jcp1)+ zably(jl,4,jc)          *zdiff
      pabcu(jl,11,jc)=pabcu(jl,11,jcp1)+ zably(jl,5,jc)*ztcon(jl)*zdiff
!
      pabcu(jl,12,jc)=pabcu(jl,12,jcp1)+ zably(jl,6,jc)*zphio(jl)*zdiff
      pabcu(jl,13,jc)=pabcu(jl,13,jcp1)+ zably(jl,7,jc)*zpsio(jl)*zdiff
!
      pabcu(jl, 7,jc)=pabcu(jl, 7,jcp1)+ zably(jl,3,jc)*zpsc2(jl)*zdiff
      pabcu(jl, 8,jc)=pabcu(jl, 8,jcp1)+ zably(jl,3,jc)*zpsc3(jl)*zdiff
      pabcu(jl, 9,jc)=pabcu(jl, 9,jcp1)+ zably(jl,3,jc)*zpsc3(jl)*zdiff
!
      pabcu(jl, 1,jc)=pabcu(jl, 1,jcp1)+ zably(jl,1,jc)*zpsh1(jl)*zdiff
      pabcu(jl, 2,jc)=pabcu(jl, 2,jcp1)+ zably(jl,1,jc)*zpsh2(jl)*zdiff
      pabcu(jl, 3,jc)=pabcu(jl, 3,jcp1)+ zably(jl,1,jc)*zpsh5(jl)*zdiff
      pabcu(jl, 4,jc)=pabcu(jl, 4,jcp1)+ zably(jl,1,jc)*zpsh3(jl)*zdiff
      pabcu(jl, 5,jc)=pabcu(jl, 5,jcp1)+ zably(jl,1,jc)*zpsh4(jl)*zdiff
      pabcu(jl, 6,jc)=pabcu(jl, 6,jcp1)+ zably(jl,1,jc)*zpsh6(jl)*zdiff
!
      pabcu(jl,14,jc)=pabcu(jl,14,jcp1)+ zuaer(jl,1) *zduc(jl,jc)*zdiff
      pabcu(jl,15,jc)=pabcu(jl,15,jcp1)+ zuaer(jl,2) *zduc(jl,jc)*zdiff
      pabcu(jl,16,jc)=pabcu(jl,16,jcp1)+ zuaer(jl,3) *zduc(jl,jc)*zdiff
      pabcu(jl,17,jc)=pabcu(jl,17,jcp1)+ zuaer(jl,4) *zduc(jl,jc)*zdiff
      pabcu(jl,18,jc)=pabcu(jl,18,jcp1)+ zuaer(jl,5) *zduc(jl,jc)*zdiff
! 
      pabcu(jl,19,jc)=pabcu(jl,19,jcp1) &
      &              +zably(jl,2,jc)*rch4/pcco2*zphm6(jl)*zdiff
      pabcu(jl,20,jc)=pabcu(jl,20,jcp1) &
      &              +zably(jl,3,jc)*rch4/pcco2*zpsm6(jl)*zdiff
      pabcu(jl,21,jc)=pabcu(jl,21,jcp1) &
      &              +zably(jl,2,jc)*rn2o/pcco2*zphn6(jl)*zdiff
      pabcu(jl,22,jc)=pabcu(jl,22,jcp1) &
      &              +zably(jl,3,jc)*rn2o/pcco2*zpsn6(jl)*zdiff
!
      pabcu(jl,23,jc)=pabcu(jl,23,jcp1) &
      &               +zably(jl,2,jc)*rcfc11/pcco2       *zdiff
      pabcu(jl,24,jc)=pabcu(jl,24,jcp1) &
      &               +zably(jl,2,jc)*rcfc12/pcco2       *zdiff
      
    END DO
  END DO
!
END DO

!
RETURN
END SUBROUTINE olwu