Changeset 998 for LMDZ4/trunk


Ignore:
Timestamp:
Sep 25, 2008, 12:24:47 PM (16 years ago)
Author:
Laurent Fairhead
Message:

Modifications necessaires a la preparation au passage au nouveau rayonnement
RRTM MPL
LF

Location:
LMDZ4/trunk/libf/phylmd
Files:
2 added
4 edited

Legend:

Unmodified
Added
Removed

  • LMDZ4/trunk/libf/phylmd/clesphys.h

    r996 r998  
    4646       REAL ecrit_mth, ecrit_tra, ecrit_reg
    4747       REAL freq_ISCCP, ecrit_ISCCP
    48        INTEGER :: ip_ebil_phy
     48       INTEGER :: ip_ebil_phy, iflag_rrtm
     49       LOGICAL ok_slab_sicOBS
    4950
    5051       COMMON/clesphys/cycle_diurne, soil_model, new_oliq,              &
    … …  
    6061     &     , ecrit_mth, ecrit_tra, ecrit_reg                            &
    6162     &     , freq_ISCCP, ecrit_ISCCP, ip_ebil_phy                       &
    62      &     , ok_lic_melt, cvl_corr                                      &
    63      &     , qsol0
     63     &     , ok_slab_sicOBS, ok_lic_melt, cvl_corr                      &
     64     &     , qsol0, iflag_rrtm
    6465     
    6566!$OMP THREADPRIVATE(/clesphys/)

  • LMDZ4/trunk/libf/phylmd/conf_phys.F90

    r996 r998  
    6969  real,SAVE           :: ratqshaut_omp
    7070  integer,SAVE        :: iflag_radia_omp
     71  integer,SAVE        :: iflag_rrtm_omp
    7172  integer,SAVE        :: iflag_cldcon_omp, ip_ebil_phy_omp
    7273  integer,SAVE        :: iflag_ratqs_omp
    … …  
    577578  call getin('iflag_radia',iflag_radia_omp)
    578579
     580!
     581!Config Key  = iflag_rrtm
     582!Config Desc = 
     583!Config Def  = 0
     584!Config Help =
     585!
     586  iflag_rrtm_omp = 0
     587  call getin('iflag_rrtm',iflag_rrtm_omp)
     588
     589!
    579590!Config Key  = iflag_cldcon
    580591!Config Desc = 
    … …  
    11651176    ratqshaut = ratqshaut_omp
    11661177    iflag_radia = iflag_radia_omp
     1178    iflag_rrtm = iflag_rrtm_omp
    11671179    iflag_cldcon = iflag_cldcon_omp
    11681180    iflag_ratqs = iflag_ratqs_omp
    … …  
    12661278  write(numout,*)' iflag_cldcon = ', iflag_cldcon
    12671279  write(numout,*)' iflag_radia = ', iflag_radia
     1280  write(numout,*)' iflag_rrtm = ', iflag_rrtm
    12681281  write(numout,*)' iflag_ratqs = ', iflag_ratqs
    12691282  write(numout,*)' seuil_inversion = ', seuil_inversion

  • LMDZ4/trunk/libf/phylmd/physiq.F

    r996 r998  
    15571557      END IF
    15581558c
     1559c
     1560!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1561! Nouvelle initialisation pour le rayonnement RRTM
     1562!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1563
     1564      call iniradia(klon,klev,paprs(1,1:klev+1))
     1565
    15591566      ENDIF
    15601567!
    … …  
    28442851     s             topswad, solswad, ! ="=
    28452852     e             cldtaupi, ! ="=
    2846      s             topswai, solswai) ! ="=
     2853     s             topswai, solswai,zqsat,flwc,fiwc) ! ="=
    28472854      ENDIF
    28482855      itaprad = 0

  • LMDZ4/trunk/libf/phylmd/radlwsw.F

    r888 r998  
    1414     .                  tau_ae, piz_ae, cg_ae,
    1515     .                  topswad, solswad,
    16      .                  cldtaupi, topswai, solswai)
     16     .                  cldtaupi, topswai, solswai,qsat,flwc,fiwc)
    1717c     
    1818      USE dimphy
    … …  
    107107c
    108108      INTEGER k, kk, i, j, iof, nb_gr
    109       EXTERNAL lw, sw
     109      EXTERNAL LW_LMDAR4,SW_LMDAR4
    110110c
    111111cIM ctes ds clesphys.h  REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12
    … …  
    143143      REAL lwdn(klon,kflev+1),lwdn0(klon,kflev+1)
    144144      REAL lwup(klon,kflev+1),lwup0(klon,kflev+1)
     145      REAL qsat(klon,klev),flwc(klon,klev),fiwc(klon,klev)
    145146c-OB
    146147cjq the following quantities are needed for the aerosol radiative forcings
    … …  
    291292      ENDDO
    292293c
    293 c======================================================================
     294c===== si iflag_rrtm=0 ================================================
    294295cIM ctes ds clesphys.h   CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
    295       CALL LW(
     296cIM ctes ds clesphys.h   CALL SW(PSCT, RCO2, zrmu0, zfract,
     297c     
     298      if (iflag_rrtm.eq.0) then
     299         CALL LW_LMDAR4(
    296300     .        PPMB, PDP,
    297301     .        PPSOL,PDT0,PEMIS,
    … …  
    303307     .        zsollwdown,
    304308     .        ZFLUP, ZFLDN, ZFLUP0,ZFLDN0)
    305 cIM ctes ds clesphys.h   CALL SW(PSCT, RCO2, zrmu0, zfract,
    306       CALL SW(PSCT, zrmu0, zfract,
     309         CALL SW_LMDAR4(PSCT, zrmu0, zfract,
    307310     S        PPMB, PDP,
    308311     S        PPSOL, PALBD, PALBP,
    … …  
    316319     s        ztopswad,zsolswad,ztopswai,zsolswai, ! diagnosed aerosol forcing
    317320     J        ok_ade, ok_aie) ! apply aerosol effects or not?
     321      else
     322c===== si iflag_rrtm=1, on passe dans SW via RECMWFL ===============
     323          PRINT*, "Cette option ne fonctionne pas encore !!!"
     324         CALL abort
     325         endif   ! if(iflag_rrtm=0)
    318326
    319327c======================================================================
    … …  
    392400      RETURN
    393401      END
    394 cIM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC,
    395       SUBROUTINE SW(PSCT, PRMU0, PFRAC,
    396      S              PPMB, PDP,
    397      S              PPSOL, PALBD, PALBP,
    398      S              PTAVE, PWV, PQS, POZON, PAER,
    399      S              PCLDSW, PTAU, POMEGA, PCG,
    400      S              PHEAT, PHEAT0,
    401      S              PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,
    402      S              ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
    403      S              tauae, pizae, cgae,
    404      s              PTAUA, POMEGAA,
    405      S              PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,
    406      J              ok_ade, ok_aie )
    407       USE dimphy     
    408       IMPLICIT none
    409 
    410 cym#include "dimensions.h"
    411 cym#include "dimphy.h"
    412 cym#include "raddim.h"
    413 #include "YOMCST.h"
    414 C
    415 C     ------------------------------------------------------------------
    416 C
    417 C     PURPOSE.
    418 C     --------
    419 C
    420 C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
    421 C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
    422 C
    423 C     METHOD.
    424 C     -------
    425 C
    426 C          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
    427 C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
    428 C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
    429 C
    430 C     REFERENCE.
    431 C     ----------
    432 C
    433 C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
    434 C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
    435 C
    436 C     AUTHOR.
    437 C     -------
    438 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    439 C
    440 C     MODIFICATIONS.
    441 C     --------------
    442 C        ORIGINAL : 89-07-14
    443 C        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
    444 c        03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
    445 C     ------------------------------------------------------------------
    446 C
    447 C* ARGUMENTS:
    448 C
    449       REAL*8 PSCT  ! constante solaire (valeur conseillee: 1370)
    450 cIM ctes ds clesphys.h   REAL*8 RCO2  ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
    451 #include "clesphys.h"
    452 C
    453       REAL*8 PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
    454       REAL*8 PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
    455       REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
    456 C
    457       REAL*8 PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
    458       REAL*8 PFRAC(KDLON)  ! fraction de la journee
    459 C
    460       REAL*8 PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
    461       REAL*8 PWV(KDLON,KFLEV)    ! SPECIFIC HUMIDITY (KG/KG)
    462       REAL*8 PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
    463       REAL*8 POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
    464       REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
    465 C
    466       REAL*8 PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
    467       REAL*8 PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
    468 C
    469       REAL*8 PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
    470       REAL*8 PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS
    471       REAL*8 PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
    472       REAL*8 POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
    473 C
    474       REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
    475       REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
    476       REAL*8 PALBPLA(KDLON)     ! PLANETARY ALBEDO
    477       REAL*8 PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
    478       REAL*8 PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
    479       REAL*8 PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
    480       REAL*8 PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
    481 C
    482 C* LOCAL VARIABLES:
    483 C
    484       REAL*8 ZOZ(KDLON,KFLEV)
    485       REAL*8 ZAKI(KDLON,2)     
    486       REAL*8 ZCLD(KDLON,KFLEV)
    487       REAL*8 ZCLEAR(KDLON)
    488       REAL*8 ZDSIG(KDLON,KFLEV)
    489       REAL*8 ZFACT(KDLON)
    490       REAL*8 ZFD(KDLON,KFLEV+1)
    491       REAL*8 ZFDOWN(KDLON,KFLEV+1)
    492       REAL*8 ZFU(KDLON,KFLEV+1)
    493       REAL*8 ZFUP(KDLON,KFLEV+1)
    494       REAL*8 ZRMU(KDLON)
    495       REAL*8 ZSEC(KDLON)
    496       REAL*8 ZUD(KDLON,5,KFLEV+1)
    497       REAL*8 ZCLDSW0(KDLON,KFLEV)
    498 c
    499       REAL*8 ZFSUP(KDLON,KFLEV+1)
    500       REAL*8 ZFSDN(KDLON,KFLEV+1)
    501       REAL*8 ZFSUP0(KDLON,KFLEV+1)
    502       REAL*8 ZFSDN0(KDLON,KFLEV+1)
    503 C
    504       INTEGER inu, jl, jk, i, k, kpl1
    505 c
    506       INTEGER swpas  ! Every swpas steps, sw is calculated
    507       PARAMETER(swpas=1)
    508 c
    509       INTEGER itapsw
    510       LOGICAL appel1er
    511       DATA itapsw /0/
    512       DATA appel1er /.TRUE./
    513       SAVE itapsw,appel1er
    514 c$OMP THREADPRIVATE(appel1er)
    515 c$OMP THREADPRIVATE(itapsw)
    516 cjq-Introduced for aerosol forcings
    517       real*8 flag_aer
    518       logical ok_ade, ok_aie    ! use aerosol forcings or not?
    519       real*8 tauae(kdlon,kflev,2)  ! aerosol optical properties
    520       real*8 pizae(kdlon,kflev,2)  ! (see aeropt.F)
    521       real*8 cgae(kdlon,kflev,2)   ! -"-
    522       REAL*8 PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
    523       REAL*8 POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
    524       REAL*8 PTOPSWAD(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
    525       REAL*8 PSOLSWAD(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
    526       REAL*8 PTOPSWAI(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
    527       REAL*8 PSOLSWAI(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
    528 cjq - Fluxes including aerosol effects
    529       REAL*8,allocatable,save :: ZFSUPAD(:,:)
    530 c$OMP THREADPRIVATE(ZFSUPAD)
    531       REAL*8,allocatable,save :: ZFSDNAD(:,:)
    532 c$OMP THREADPRIVATE(ZFSDNAD)
    533       REAL*8,allocatable,save :: ZFSUPAI(:,:)
    534 c$OMP THREADPRIVATE(ZFSUPAI)
    535       REAL*8,allocatable,save :: ZFSDNAI(:,:)
    536 c$OMP THREADPRIVATE(ZFSDNAI)
    537       logical initialized
    538 cym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
    539 !rv
    540       save flag_aer
    541 c$OMP THREADPRIVATE(flag_aer)
    542       data initialized/.false./
    543       save initialized
    544 c$OMP THREADPRIVATE(initialized)
    545 cjq-end
    546       if(.not.initialized) then
    547         flag_aer=0.
    548         initialized=.TRUE.
    549         allocate(ZFSUPAD(KDLON,KFLEV+1))
    550         allocate(ZFSDNAD(KDLON,KFLEV+1))
    551         allocate(ZFSUPAI(KDLON,KFLEV+1))
    552         allocate(ZFSDNAI(KDLON,KFLEV+1))
    553         ZFSUPAD(:,:)=0.
    554         ZFSDNAD(:,:)=0.
    555         ZFSUPAI(:,:)=0.
    556         ZFSDNAI(:,:)=0.
    557        
    558       endif
    559 !rv
    560      
    561 c
    562       IF (appel1er) THEN
    563          PRINT*, 'SW calling frequency : ', swpas
    564          PRINT*, "   In general, it should be 1"
    565          appel1er = .FALSE.
    566       ENDIF
    567 C     ------------------------------------------------------------------
    568       IF (MOD(itapsw,swpas).EQ.0) THEN
    569 c
    570       DO JK = 1 , KFLEV
    571       DO JL = 1, KDLON
    572          ZCLDSW0(JL,JK) = 0.0
    573          ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG
    574      .               *PDP(JL,JK)*(101325.0/PPSOL(JL))
    575       ENDDO
    576       ENDDO
    577 C
    578 C
    579 c clear-sky:
    580 cIM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
    581       CALL SWU(PSCT,ZCLDSW0,PPMB,PPSOL,
    582      S         PRMU0,PFRAC,PTAVE,PWV,
    583      S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
    584       INU = 1
    585       CALL SW1S(INU,
    586      S     PAER, flag_aer, tauae, pizae, cgae,
    587      S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
    588      S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
    589      S     ZFD, ZFU)
    590       INU = 2
    591       CALL SW2S(INU,
    592      S     PAER, flag_aer, tauae, pizae, cgae,
    593      S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
    594      S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
    595      S     PWV, PQS,
    596      S     ZFDOWN, ZFUP)
    597       DO JK = 1 , KFLEV+1
    598       DO JL = 1, KDLON
    599          ZFSUP0(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
    600          ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
    601       ENDDO
    602       ENDDO
    603      
    604       flag_aer=0.0
    605       CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
    606      S         PRMU0,PFRAC,PTAVE,PWV,
    607      S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
    608       INU = 1
    609       CALL SW1S(INU,
    610      S     PAER, flag_aer, tauae, pizae, cgae,
    611      S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
    612      S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
    613      S     ZFD, ZFU)
    614       INU = 2
    615       CALL SW2S(INU,
    616      S     PAER, flag_aer, tauae, pizae, cgae,
    617      S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
    618      S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
    619      S     PWV, PQS,
    620      S    ZFDOWN, ZFUP)
    621 
    622 c cloudy-sky:
    623      
    624       DO JK = 1 , KFLEV+1
    625       DO JL = 1, KDLON
    626          ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
    627          ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
    628       ENDDO
    629       ENDDO
    630      
    631 c     
    632       IF (ok_ade) THEN
    633 c
    634 c cloudy-sky + aerosol dir OB
    635       flag_aer=1.0
    636       CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
    637      S         PRMU0,PFRAC,PTAVE,PWV,
    638      S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
    639       INU = 1
    640       CALL SW1S(INU,
    641      S     PAER, flag_aer, tauae, pizae, cgae,
    642      S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
    643      S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
    644      S     ZFD, ZFU)
    645       INU = 2
    646       CALL SW2S(INU,
    647      S     PAER, flag_aer, tauae, pizae, cgae,
    648      S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
    649      S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
    650      S     PWV, PQS,
    651      S    ZFDOWN, ZFUP)
    652       DO JK = 1 , KFLEV+1
    653       DO JL = 1, KDLON
    654          ZFSUPAD(JL,JK) = ZFSUP(JL,JK)
    655          ZFSDNAD(JL,JK) = ZFSDN(JL,JK)
    656          ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
    657          ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
    658       ENDDO
    659       ENDDO
    660      
    661       ENDIF ! ok_ade
    662      
    663       IF (ok_aie) THEN
    664          
    665 cjq   cloudy-sky + aerosol direct + aerosol indirect
    666       flag_aer=1.0
    667       CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
    668      S         PRMU0,PFRAC,PTAVE,PWV,
    669      S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
    670       INU = 1
    671       CALL SW1S(INU,
    672      S     PAER, flag_aer, tauae, pizae, cgae,
    673      S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
    674      S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
    675      S     ZFD, ZFU)
    676       INU = 2
    677       CALL SW2S(INU,
    678      S     PAER, flag_aer, tauae, pizae, cgae,
    679      S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
    680      S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
    681      S     PWV, PQS,
    682      S    ZFDOWN, ZFUP)
    683       DO JK = 1 , KFLEV+1
    684       DO JL = 1, KDLON
    685          ZFSUPAI(JL,JK) = ZFSUP(JL,JK)
    686          ZFSDNAI(JL,JK) = ZFSDN(JL,JK)         
    687          ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
    688          ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
    689       ENDDO
    690       ENDDO
    691       ENDIF ! ok_aie     
    692 cjq -end
    693      
    694       itapsw = 0
    695       ENDIF
    696       itapsw = itapsw + 1
    697 C
    698       DO k = 1, KFLEV
    699          kpl1 = k+1
    700          DO i = 1, KDLON
    701             PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
    702      .                     -(ZFSDN(i,k)-ZFSDN(i,kpl1))
    703             PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
    704             PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))
    705      .                     -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
    706             PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
    707          ENDDO
    708       ENDDO
    709       DO i = 1, KDLON
    710          PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
    711 c
    712          PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
    713          PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
    714 c
    715          PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
    716          PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
    717 c-OB
    718          PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1)
    719          PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1)
    720 c
    721          PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1)
    722          PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1)
    723 c-fin
    724       ENDDO
    725 C
    726       RETURN
    727       END
    728 c
    729 cIM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
    730       SUBROUTINE SWU (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
    731      S                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
    732      S                PRMU,PSEC,PUD)
    733       USE dimphy
    734       IMPLICIT none
    735 cym#include "dimensions.h"
    736 cym#include "dimphy.h"
    737 cym#include "raddim.h"
    738 #include "radepsi.h"
    739 #include "radopt.h"
    740 #include "YOMCST.h"
    741 C
    742 C* ARGUMENTS:
    743 C
    744       REAL*8 PSCT
    745 cIM ctes ds clesphys.h   REAL*8 RCO2
    746 #include "clesphys.h"
    747       REAL*8 PCLDSW(KDLON,KFLEV)
    748       REAL*8 PPMB(KDLON,KFLEV+1)
    749       REAL*8 PPSOL(KDLON)
    750       REAL*8 PRMU0(KDLON)
    751       REAL*8 PFRAC(KDLON)
    752       REAL*8 PTAVE(KDLON,KFLEV)
    753       REAL*8 PWV(KDLON,KFLEV)
    754 C
    755       REAL*8 PAKI(KDLON,2)
    756       REAL*8 PCLD(KDLON,KFLEV)
    757       REAL*8 PCLEAR(KDLON)
    758       REAL*8 PDSIG(KDLON,KFLEV)
    759       REAL*8 PFACT(KDLON)
    760       REAL*8 PRMU(KDLON)
    761       REAL*8 PSEC(KDLON)
    762       REAL*8 PUD(KDLON,5,KFLEV+1)
    763 C
    764 C* LOCAL VARIABLES:
    765 C
    766       INTEGER IIND(2)
    767       REAL*8 ZC1J(KDLON,KFLEV+1)
    768       REAL*8 ZCLEAR(KDLON)
    769       REAL*8 ZCLOUD(KDLON)
    770       REAL*8 ZN175(KDLON)
    771       REAL*8 ZN190(KDLON)
    772       REAL*8 ZO175(KDLON)
    773       REAL*8 ZO190(KDLON)
    774       REAL*8 ZSIGN(KDLON)
    775       REAL*8 ZR(KDLON,2)
    776       REAL*8 ZSIGO(KDLON)
    777       REAL*8 ZUD(KDLON,2)
    778       REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
    779       INTEGER jl, jk, jkp1, jkl, jklp1, ja
    780 C
    781 C* Prescribed Data:
    782 c
    783       REAL*8 ZPDH2O,ZPDUMG
    784       SAVE ZPDH2O,ZPDUMG
    785 c$OMP THREADPRIVATE(ZPDH2O,ZPDUMG)
    786       REAL*8 ZPRH2O,ZPRUMG
    787       SAVE ZPRH2O,ZPRUMG
    788 c$OMP THREADPRIVATE(ZPRH2O,ZPRUMG)
    789       REAL*8 RTDH2O,RTDUMG
    790       SAVE RTDH2O,RTDUMG
    791 c$OMP THREADPRIVATE(RTDH2O,RTDUMG)
    792       REAL*8 RTH2O ,RTUMG
    793       SAVE RTH2O ,RTUMG
    794 c$OMP THREADPRIVATE(RTH2O ,RTUMG)
    795       DATA ZPDH2O,ZPDUMG / 0.8   , 0.75 /
    796       DATA ZPRH2O,ZPRUMG / 30000., 30000. /
    797       DATA RTDH2O,RTDUMG /  0.40  , 0.375 /
    798       DATA RTH2O ,RTUMG  /  240.  , 240.  /
    799 C     ------------------------------------------------------------------
    800 C
    801 C*         1.     COMPUTES AMOUNTS OF ABSORBERS
    802 C                 -----------------------------
    803 C
    804  100  CONTINUE
    805 C
    806       IIND(1)=1
    807       IIND(2)=2
    808 C     
    809 C
    810 C*         1.1    INITIALIZES QUANTITIES
    811 C                 ----------------------
    812 C
    813  110  CONTINUE
    814 C
    815       DO 111 JL = 1, KDLON
    816       PUD(JL,1,KFLEV+1)=0.
    817       PUD(JL,2,KFLEV+1)=0.
    818       PUD(JL,3,KFLEV+1)=0.
    819       PUD(JL,4,KFLEV+1)=0.
    820       PUD(JL,5,KFLEV+1)=0.
    821       PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
    822       PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
    823       PSEC(JL)=1./PRMU(JL)
    824       ZC1J(JL,KFLEV+1)=0.
    825  111  CONTINUE
    826 C
    827 C*          1.3    AMOUNTS OF ABSORBERS
    828 C                  --------------------
    829 C
    830  130  CONTINUE
    831 C
    832       DO 131 JL= 1, KDLON
    833       ZUD(JL,1) = 0.
    834       ZUD(JL,2) = 0.
    835       ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
    836       ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
    837       ZSIGO(JL) = PPSOL(JL)
    838       ZCLEAR(JL)=1.
    839       ZCLOUD(JL)=0.
    840  131  CONTINUE
    841 C
    842       DO 133 JK = 1 , KFLEV
    843       JKP1 = JK + 1
    844       JKL = KFLEV+1 - JK
    845       JKLP1 = JKL+1
    846       DO 132 JL = 1, KDLON
    847       ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
    848       ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
    849       ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
    850       ZSIGN(JL) = 100. * PPMB(JL,JKP1)
    851       PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
    852       ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
    853       ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
    854       ZDSCO2 = ZO175(JL) - ZN175(JL)
    855       ZDSH2O = ZO190(JL) - ZN190(JL)
    856       PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
    857      .             * ZDSH2O * ZWH2O  * ZRTH
    858       PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
    859      .             * ZDSCO2 * RCO2 * ZRTU
    860       ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
    861       PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
    862       PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
    863       ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
    864       ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
    865       ZSIGO(JL) = ZSIGN(JL)
    866       ZO175(JL) = ZN175(JL)
    867       ZO190(JL) = ZN190(JL)
    868 C     
    869       IF (NOVLP.EQ.1) THEN
    870          ZCLEAR(JL)=ZCLEAR(JL)
    871      S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
    872      S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
    873          ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
    874          ZCLOUD(JL) = PCLDSW(JL,JKL)
    875       ELSE IF (NOVLP.EQ.2) THEN
    876          ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
    877          ZC1J(JL,JKL) = ZCLOUD(JL)
    878       ELSE IF (NOVLP.EQ.3) THEN
    879          ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
    880          ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
    881          ZC1J(JL,JKL) = ZCLOUD(JL)
    882       END IF
    883  132  CONTINUE
    884  133  CONTINUE
    885       DO 134 JL=1, KDLON
    886       PCLEAR(JL)=1.-ZC1J(JL,1)
    887  134  CONTINUE
    888       DO 136 JK=1,KFLEV
    889       DO 135 JL=1, KDLON
    890       IF (PCLEAR(JL).LT.1.) THEN
    891          PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
    892       ELSE
    893          PCLD(JL,JK)=0.
    894       END IF
    895  135  CONTINUE
    896  136  CONTINUE           
    897 C     
    898 C
    899 C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
    900 C                 -----------------------------------------------
    901 C
    902  140  CONTINUE
    903 C
    904       DO 142 JA = 1,2
    905       DO 141 JL = 1, KDLON
    906       ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
    907  141  CONTINUE
    908  142  CONTINUE
    909 C
    910       CALL SWTT1(2, 2, IIND, ZUD, ZR)
    911 C
    912       DO 144 JA = 1,2
    913       DO 143 JL = 1, KDLON
    914       PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
    915  143  CONTINUE
    916  144  CONTINUE
    917 C
    918 C
    919 C     ------------------------------------------------------------------
    920 C
    921       RETURN
    922       END
    923       SUBROUTINE SW1S ( KNU
    924      S  ,  PAER  , flag_aer, tauae, pizae, cgae
    925      S  ,  PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW
    926      S  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD 
    927      S  ,  PFD   , PFU)
    928       USE dimphy
    929       IMPLICIT none
    930 cym#include "dimensions.h"
    931 cym#include "dimphy.h"
    932 cym#include "raddim.h"
    933 C
    934 C     ------------------------------------------------------------------
    935 C     PURPOSE.
    936 C     --------
    937 C
    938 C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
    939 C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
    940 C
    941 C     METHOD.
    942 C     -------
    943 C
    944 C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
    945 C     CONTINUUM SCATTERING
    946 C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
    947 C
    948 C     REFERENCE.
    949 C     ----------
    950 C
    951 C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
    952 C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
    953 C
    954 C     AUTHOR.
    955 C     -------
    956 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    957 C
    958 C     MODIFICATIONS.
    959 C     --------------
    960 C        ORIGINAL : 89-07-14
    961 C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
    962 C     ------------------------------------------------------------------
    963 C
    964 C* ARGUMENTS:
    965 C
    966       INTEGER KNU
    967 c-OB
    968       real*8 flag_aer
    969       real*8 tauae(kdlon,kflev,2)
    970       real*8 pizae(kdlon,kflev,2)
    971       real*8 cgae(kdlon,kflev,2)
    972       REAL*8 PAER(KDLON,KFLEV,5)
    973       REAL*8 PALBD(KDLON,2)
    974       REAL*8 PALBP(KDLON,2)
    975       REAL*8 PCG(KDLON,2,KFLEV) 
    976       REAL*8 PCLD(KDLON,KFLEV)
    977       REAL*8 PCLDSW(KDLON,KFLEV)
    978       REAL*8 PCLEAR(KDLON)
    979       REAL*8 PDSIG(KDLON,KFLEV)
    980       REAL*8 POMEGA(KDLON,2,KFLEV)
    981       REAL*8 POZ(KDLON,KFLEV)
    982       REAL*8 PRMU(KDLON)
    983       REAL*8 PSEC(KDLON)
    984       REAL*8 PTAU(KDLON,2,KFLEV)
    985       REAL*8 PUD(KDLON,5,KFLEV+1)
    986 C
    987       REAL*8 PFD(KDLON,KFLEV+1)
    988       REAL*8 PFU(KDLON,KFLEV+1)
    989 C
    990 C* LOCAL VARIABLES:
    991 C
    992       INTEGER IIND(4)
    993 C     
    994       REAL*8 ZCGAZ(KDLON,KFLEV)
    995       REAL*8 ZDIFF(KDLON)
    996       REAL*8 ZDIRF(KDLON)       
    997       REAL*8 ZPIZAZ(KDLON,KFLEV)
    998       REAL*8 ZRAYL(KDLON)
    999       REAL*8 ZRAY1(KDLON,KFLEV+1)
    1000       REAL*8 ZRAY2(KDLON,KFLEV+1)
    1001       REAL*8 ZREFZ(KDLON,2,KFLEV+1)
    1002       REAL*8 ZRJ(KDLON,6,KFLEV+1)
    1003       REAL*8 ZRJ0(KDLON,6,KFLEV+1)
    1004       REAL*8 ZRK(KDLON,6,KFLEV+1)
    1005       REAL*8 ZRK0(KDLON,6,KFLEV+1)
    1006       REAL*8 ZRMUE(KDLON,KFLEV+1)
    1007       REAL*8 ZRMU0(KDLON,KFLEV+1)
    1008       REAL*8 ZR(KDLON,4)
    1009       REAL*8 ZTAUAZ(KDLON,KFLEV)
    1010       REAL*8 ZTRA1(KDLON,KFLEV+1)
    1011       REAL*8 ZTRA2(KDLON,KFLEV+1)
    1012       REAL*8 ZW(KDLON,4)
    1013 C
    1014       INTEGER jl, jk, k, jaj, ikm1, ikl
    1015 c
    1016 c Prescribed Data:
    1017 c
    1018       REAL*8 RSUN(2)
    1019       SAVE RSUN
    1020 c$OMP THREADPRIVATE(RSUN)
    1021       REAL*8 RRAY(2,6)
    1022       SAVE RRAY
    1023 c$OMP THREADPRIVATE(RRAY)
    1024       DATA RSUN(1) / 0.441676 /
    1025       DATA RSUN(2) / 0.558324 /
    1026       DATA (RRAY(1,K),K=1,6) /
    1027      S .428937E-01, .890743E+00,-.288555E+01,
    1028      S .522744E+01,-.469173E+01, .161645E+01/
    1029       DATA (RRAY(2,K),K=1,6) /
    1030      S .697200E-02, .173297E-01,-.850903E-01,
    1031      S .248261E+00,-.302031E+00, .129662E+00/
    1032 C     ------------------------------------------------------------------
    1033 C
    1034 C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
    1035 C                 ----------------------- ------------------
    1036 C
    1037  100  CONTINUE
    1038 C
    1039 C
    1040 C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
    1041 C                 -----------------------------------------
    1042 C
    1043  110  CONTINUE
    1044 C
    1045       DO 111 JL = 1, KDLON
    1046       ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)
    1047      S          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)
    1048      S          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))
    1049  111  CONTINUE
    1050 C
    1051 C
    1052 C     ------------------------------------------------------------------
    1053 C
    1054 C*         2.    CONTINUUM SCATTERING CALCULATIONS
    1055 C                ---------------------------------
    1056 C
    1057  200  CONTINUE
    1058 C
    1059 C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
    1060 C                --------------------------------
    1061 C 
    1062  210  CONTINUE
    1063 C
    1064       CALL SWCLR ( KNU
    1065      S  , PAER   , flag_aer, tauae, pizae, cgae
    1066      S  , PALBP  , PDSIG , ZRAYL, PSEC
    1067      S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
    1068      S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
    1069 C
    1070 C
    1071 C*         2.2   CLOUDY FRACTION OF THE COLUMN
    1072 C                -----------------------------
    1073 C
    1074  220  CONTINUE
    1075 C
    1076       CALL SWR ( KNU
    1077      S  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL
    1078      S  , PSEC  ,PTAU
    1079      S  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE
    1080      S  , ZTAUAZ,ZTRA1 ,ZTRA2)
    1081 C
    1082 C
    1083 C     ------------------------------------------------------------------
    1084 C
    1085 C*         3.    OZONE ABSORPTION
    1086 C                ----------------
    1087 C
    1088  300  CONTINUE
    1089 C
    1090       IIND(1)=1
    1091       IIND(2)=3
    1092       IIND(3)=1
    1093       IIND(4)=3
    1094 C     
    1095 C
    1096 C*         3.1   DOWNWARD FLUXES
    1097 C                ---------------
    1098 C
    1099  310  CONTINUE
    1100 C
    1101       JAJ = 2
    1102 C
    1103       DO 311 JL = 1, KDLON
    1104       ZW(JL,1)=0.
    1105       ZW(JL,2)=0.
    1106       ZW(JL,3)=0.
    1107       ZW(JL,4)=0.
    1108       PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
    1109      S     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
    1110  311  CONTINUE
    1111       DO 314 JK = 1 , KFLEV
    1112       IKL = KFLEV+1-JK
    1113       DO 312 JL = 1, KDLON
    1114       ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
    1115       ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
    1116       ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
    1117       ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
    1118  312  CONTINUE
    1119 C
    1120       CALL SWTT1(KNU, 4, IIND, ZW, ZR)
    1121 C
    1122       DO 313 JL = 1, KDLON
    1123       ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
    1124       ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
    1125       PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
    1126      S                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
    1127  313  CONTINUE
    1128  314  CONTINUE
    1129 C
    1130 C
    1131 C*         3.2   UPWARD FLUXES
    1132 C                -------------
    1133 C
    1134  320  CONTINUE
    1135 C
    1136       DO 325 JL = 1, KDLON
    1137       PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)
    1138      S               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))
    1139      S          * RSUN(KNU)
    1140  325  CONTINUE
    1141 C
    1142       DO 328 JK = 2 , KFLEV+1
    1143       IKM1=JK-1
    1144       DO 326 JL = 1, KDLON
    1145       ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
    1146       ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66
    1147       ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
    1148       ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66
    1149  326  CONTINUE
    1150 C
    1151       CALL SWTT1(KNU, 4, IIND, ZW, ZR)
    1152 C
    1153       DO 327 JL = 1, KDLON
    1154       ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
    1155       ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
    1156       PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
    1157      S                 +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
    1158  327  CONTINUE
    1159  328  CONTINUE
    1160 C
    1161 C     ------------------------------------------------------------------
    1162 C
    1163       RETURN
    1164       END
    1165       SUBROUTINE SW2S ( KNU
    1166      S  ,  PAER  , flag_aer, tauae, pizae, cgae
    1167      S  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW
    1168      S  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU
    1169      S  ,  PUD   ,PWV , PQS
    1170      S  ,  PFDOWN,PFUP                                            )
    1171       USE dimphy
    1172       IMPLICIT none
    1173 cym#include "dimensions.h"
    1174 cym#include "dimphy.h"
    1175 cym#include "raddim.h"
    1176 #include "radepsi.h"
    1177 C
    1178 C     ------------------------------------------------------------------
    1179 C     PURPOSE.
    1180 C     --------
    1181 C
    1182 C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
    1183 C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
    1184 C
    1185 C     METHOD.
    1186 C     -------
    1187 C
    1188 C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
    1189 C     CONTINUUM SCATTERING
    1190 C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
    1191 C     A GREY MOLECULAR ABSORPTION
    1192 C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
    1193 C     OF ABSORBERS
    1194 C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
    1195 C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
    1196 C
    1197 C     REFERENCE.
    1198 C     ----------
    1199 C
    1200 C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
    1201 C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
    1202 C
    1203 C     AUTHOR.
    1204 C     -------
    1205 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    1206 C
    1207 C     MODIFICATIONS.
    1208 C     --------------
    1209 C        ORIGINAL : 89-07-14
    1210 C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
    1211 C     ------------------------------------------------------------------
    1212 C* ARGUMENTS:
    1213 C
    1214       INTEGER KNU
    1215 c-OB
    1216       real*8 flag_aer
    1217       real*8 tauae(kdlon,kflev,2)
    1218       real*8 pizae(kdlon,kflev,2)
    1219       real*8 cgae(kdlon,kflev,2)
    1220       REAL*8 PAER(KDLON,KFLEV,5)
    1221       REAL*8 PAKI(KDLON,2)
    1222       REAL*8 PALBD(KDLON,2)
    1223       REAL*8 PALBP(KDLON,2)
    1224       REAL*8 PCG(KDLON,2,KFLEV)
    1225       REAL*8 PCLD(KDLON,KFLEV)
    1226       REAL*8 PCLDSW(KDLON,KFLEV)
    1227       REAL*8 PCLEAR(KDLON)
    1228       REAL*8 PDSIG(KDLON,KFLEV)
    1229       REAL*8 POMEGA(KDLON,2,KFLEV)
    1230       REAL*8 POZ(KDLON,KFLEV)
    1231       REAL*8 PQS(KDLON,KFLEV)
    1232       REAL*8 PRMU(KDLON)
    1233       REAL*8 PSEC(KDLON)
    1234       REAL*8 PTAU(KDLON,2,KFLEV)
    1235       REAL*8 PUD(KDLON,5,KFLEV+1)
    1236       REAL*8 PWV(KDLON,KFLEV)
    1237 C
    1238       REAL*8 PFDOWN(KDLON,KFLEV+1)
    1239       REAL*8 PFUP(KDLON,KFLEV+1)
    1240 C
    1241 C* LOCAL VARIABLES:
    1242 C
    1243       INTEGER IIND2(2), IIND3(3)
    1244       REAL*8 ZCGAZ(KDLON,KFLEV)
    1245       REAL*8 ZFD(KDLON,KFLEV+1)
    1246       REAL*8 ZFU(KDLON,KFLEV+1)
    1247       REAL*8 ZG(KDLON)
    1248       REAL*8 ZGG(KDLON)
    1249       REAL*8 ZPIZAZ(KDLON,KFLEV)
    1250       REAL*8 ZRAYL(KDLON)
    1251       REAL*8 ZRAY1(KDLON,KFLEV+1)
    1252       REAL*8 ZRAY2(KDLON,KFLEV+1)
    1253       REAL*8 ZREF(KDLON)
    1254       REAL*8 ZREFZ(KDLON,2,KFLEV+1)
    1255       REAL*8 ZRE1(KDLON)
    1256       REAL*8 ZRE2(KDLON)
    1257       REAL*8 ZRJ(KDLON,6,KFLEV+1)
    1258       REAL*8 ZRJ0(KDLON,6,KFLEV+1)
    1259       REAL*8 ZRK(KDLON,6,KFLEV+1)
    1260       REAL*8 ZRK0(KDLON,6,KFLEV+1)
    1261       REAL*8 ZRL(KDLON,8)
    1262       REAL*8 ZRMUE(KDLON,KFLEV+1)
    1263       REAL*8 ZRMU0(KDLON,KFLEV+1)
    1264       REAL*8 ZRMUZ(KDLON)
    1265       REAL*8 ZRNEB(KDLON)
    1266       REAL*8 ZRUEF(KDLON,8)
    1267       REAL*8 ZR1(KDLON)
    1268       REAL*8 ZR2(KDLON,2)
    1269       REAL*8 ZR3(KDLON,3)
    1270       REAL*8 ZR4(KDLON)
    1271       REAL*8 ZR21(KDLON)
    1272       REAL*8 ZR22(KDLON)
    1273       REAL*8 ZS(KDLON)
    1274       REAL*8 ZTAUAZ(KDLON,KFLEV)
    1275       REAL*8 ZTO1(KDLON)
    1276       REAL*8 ZTR(KDLON,2,KFLEV+1)
    1277       REAL*8 ZTRA1(KDLON,KFLEV+1)
    1278       REAL*8 ZTRA2(KDLON,KFLEV+1)
    1279       REAL*8 ZTR1(KDLON)
    1280       REAL*8 ZTR2(KDLON)
    1281       REAL*8 ZW(KDLON)   
    1282       REAL*8 ZW1(KDLON)
    1283       REAL*8 ZW2(KDLON,2)
    1284       REAL*8 ZW3(KDLON,3)
    1285       REAL*8 ZW4(KDLON)
    1286       REAL*8 ZW5(KDLON)
    1287 C
    1288       INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
    1289       INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
    1290       REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
    1291 C
    1292 C* Prescribed Data:
    1293 C
    1294       REAL*8 RSUN(2)
    1295       SAVE RSUN
    1296 c$OMP THREADPRIVATE(RSUN)
    1297       REAL*8 RRAY(2,6)
    1298       SAVE RRAY
    1299 c$OMP THREADPRIVATE(RRAY)
    1300       DATA RSUN(1) / 0.441676 /
    1301       DATA RSUN(2) / 0.558324 /
    1302       DATA (RRAY(1,K),K=1,6) /
    1303      S .428937E-01, .890743E+00,-.288555E+01,
    1304      S .522744E+01,-.469173E+01, .161645E+01/
    1305       DATA (RRAY(2,K),K=1,6) /
    1306      S .697200E-02, .173297E-01,-.850903E-01,
    1307      S .248261E+00,-.302031E+00, .129662E+00/
    1308 C
    1309 C     ------------------------------------------------------------------
    1310 C
    1311 C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
    1312 C                 -------------------------------------------
    1313 C
    1314  100  CONTINUE
    1315 C
    1316 C
    1317 C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
    1318 C                 -----------------------------------------
    1319 C
    1320  110  CONTINUE
    1321 C
    1322       DO 111 JL = 1, KDLON
    1323       ZRMUM1 = 1. - PRMU(JL)
    1324       ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1
    1325      S          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1
    1326      S          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))
    1327  111  CONTINUE
    1328 C
    1329 C
    1330 C     ------------------------------------------------------------------
    1331 C
    1332 C*         2.    CONTINUUM SCATTERING CALCULATIONS
    1333 C                ---------------------------------
    1334 C
    1335  200  CONTINUE
    1336 C
    1337 C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
    1338 C                --------------------------------
    1339 C 
    1340  210  CONTINUE
    1341 C
    1342       CALL SWCLR ( KNU
    1343      S  , PAER   , flag_aer, tauae, pizae, cgae
    1344      S  , PALBP  , PDSIG , ZRAYL, PSEC
    1345      S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
    1346      S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
    1347 C
    1348 C
    1349 C*         2.2   CLOUDY FRACTION OF THE COLUMN
    1350 C                -----------------------------
    1351 C
    1352  220  CONTINUE
    1353 C
    1354       CALL SWR ( KNU
    1355      S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL
    1356      S  , PSEC  , PTAU
    1357      S  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE
    1358      S  , ZTAUAZ, ZTRA1 , ZTRA2)
    1359 C
    1360 C
    1361 C     ------------------------------------------------------------------
    1362 C
    1363 C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
    1364 C                ------------------------------------------------------
    1365 C
    1366  300  CONTINUE
    1367 C
    1368       JN = 2
    1369 C
    1370       DO 361 JABS=1,2
    1371 C
    1372 C
    1373 C*         3.1  SURFACE CONDITIONS
    1374 C               ------------------
    1375 C
    1376  310  CONTINUE
    1377 C
    1378       DO 311 JL = 1, KDLON
    1379       ZREFZ(JL,2,1) = PALBD(JL,KNU)
    1380       ZREFZ(JL,1,1) = PALBD(JL,KNU)
    1381  311  CONTINUE
    1382 C
    1383 C
    1384 C*         3.2  INTRODUCING CLOUD EFFECTS
    1385 C               -------------------------
    1386 C
    1387  320  CONTINUE
    1388 C
    1389       DO 324 JK = 2 , KFLEV+1
    1390       JKM1 = JK - 1
    1391       IKL=KFLEV+1-JKM1
    1392       DO 322 JL = 1, KDLON
    1393       ZRNEB(JL) = PCLD(JL,JKM1)
    1394       IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
    1395          ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
    1396          ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
    1397          ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
    1398          ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
    1399       ELSE
    1400          ZAA=PUD(JL,JABS,JKM1)
    1401          ZBB=ZAA
    1402       END IF
    1403       ZRKI = PAKI(JL,JABS)
    1404       ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
    1405       ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
    1406       ZTR1(JL) = 0.
    1407       ZRE1(JL) = 0.
    1408       ZTR2(JL) = 0.
    1409       ZRE2(JL) = 0.
    1410 C
    1411       ZW(JL)= POMEGA(JL,KNU,JKM1)
    1412       ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
    1413      S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
    1414      S               + ZBB * ZRKI
    1415 
    1416       ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
    1417       ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
    1418       ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
    1419      S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
    1420       ZW(JL) = ZR21(JL) / ZTO1(JL)
    1421       ZREF(JL) = ZREFZ(JL,1,JKM1)
    1422       ZRMUZ(JL) = ZRMUE(JL,JK)
    1423  322  CONTINUE
    1424 C
    1425       CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,
    1426      S          ZRE1, ZRE2, ZTR1, ZTR2)
    1427 C
    1428       DO 323 JL = 1, KDLON
    1429 C
    1430       ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
    1431      S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
    1432      S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
    1433      S               + ZRNEB(JL) * ZRE1(JL)
    1434 C
    1435       ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
    1436      S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
    1437 C
    1438       ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
    1439      S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)
    1440      S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)
    1441      S             + ZRNEB(JL) * ZRE2(JL)
    1442 C
    1443       ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
    1444      S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
    1445      S              * ZREFZ(JL,1,JKM1)))
    1446      S              * ZG(JL) * (1. -ZRNEB(JL))
    1447 C
    1448  323  CONTINUE
    1449  324  CONTINUE
    1450 C
    1451 C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
    1452 C               -------------------------------------------------
    1453 C
    1454  330  CONTINUE
    1455 C
    1456       DO 351 JREF=1,2
    1457 C
    1458       JN = JN + 1
    1459 C
    1460       DO 331 JL = 1, KDLON
    1461       ZRJ(JL,JN,KFLEV+1) = 1.
    1462       ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
    1463  331  CONTINUE
    1464 C
    1465       DO 333 JK = 1 , KFLEV
    1466       JKL = KFLEV+1 - JK
    1467       JKLP1 = JKL + 1
    1468       DO 332 JL = 1, KDLON
    1469       ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
    1470       ZRJ(JL,JN,JKL) = ZRE11
    1471       ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
    1472  332  CONTINUE
    1473  333  CONTINUE
    1474  351  CONTINUE
    1475  361  CONTINUE
    1476 C
    1477 C
    1478 C     ------------------------------------------------------------------
    1479 C
    1480 C*         4.    INVERT GREY AND CONTINUUM FLUXES
    1481 C                --------------------------------
    1482 C
    1483  400  CONTINUE
    1484 C
    1485 C
    1486 C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
    1487 C                ---------------------------------------------
    1488 C
    1489  410  CONTINUE
    1490 C
    1491       DO 414 JK = 1 , KFLEV+1
    1492       DO 413 JAJ = 1 , 5 , 2
    1493       JAJP = JAJ + 1
    1494       DO 412 JL = 1, KDLON
    1495       ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
    1496       ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
    1497       ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
    1498       ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
    1499  412  CONTINUE
    1500  413  CONTINUE
    1501  414  CONTINUE
    1502 C
    1503       DO 417 JK = 1 , KFLEV+1
    1504       DO 416 JAJ = 2 , 6 , 2
    1505       DO 415 JL = 1, KDLON
    1506       ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
    1507       ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
    1508  415  CONTINUE
    1509  416  CONTINUE
    1510  417  CONTINUE
    1511 C
    1512 C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
    1513 C                 ---------------------------------------------
    1514 C
    1515  420  CONTINUE
    1516 C
    1517       DO 437 JK = 1 , KFLEV+1
    1518       JKKI = 1
    1519       DO 425 JAJ = 1 , 2
    1520       IIND2(1)=JAJ
    1521       IIND2(2)=JAJ
    1522       DO 424 JN = 1 , 2
    1523       JN2J = JN + 2 * JAJ
    1524       JKKP4 = JKKI + 4
    1525 C
    1526 C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
    1527 C                 --------------------------
    1528 C
    1529  4210 CONTINUE
    1530 C
    1531       DO 4211 JL = 1, KDLON
    1532       ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
    1533      S                               / PAKI(JL,JAJ)
    1534       ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
    1535      S                               / PAKI(JL,JAJ)
    1536  4211 CONTINUE
    1537 C
    1538 C*         4.2.2  TRANSMISSION FUNCTION
    1539 C                 ---------------------
    1540 C
    1541  4220 CONTINUE
    1542 C
    1543       CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)
    1544 C
    1545       DO 4221 JL = 1, KDLON
    1546       ZRL(JL,JKKI) = ZR2(JL,1)
    1547       ZRUEF(JL,JKKI) = ZW2(JL,1)
    1548       ZRL(JL,JKKP4) = ZR2(JL,2)
    1549       ZRUEF(JL,JKKP4) = ZW2(JL,2)
    1550  4221 CONTINUE
    1551 C
    1552       JKKI=JKKI+1
    1553  424  CONTINUE
    1554  425  CONTINUE
    1555 C
    1556 C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
    1557 C                 ------------------------------------------------------
    1558 C
    1559  430  CONTINUE
    1560 C
    1561       DO 431 JL = 1, KDLON
    1562       PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
    1563      S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
    1564       PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
    1565      S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
    1566  431  CONTINUE
    1567  437  CONTINUE
    1568 C
    1569 C
    1570 C     ------------------------------------------------------------------
    1571 C
    1572 C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
    1573 C                ----------------------------------------
    1574 C
    1575  500  CONTINUE
    1576 C
    1577 C
    1578 C*         5.1   DOWNWARD FLUXES
    1579 C                ---------------
    1580 C
    1581  510  CONTINUE
    1582 C
    1583       JAJ = 2
    1584       IIND3(1)=1
    1585       IIND3(2)=2
    1586       IIND3(3)=3
    1587 C     
    1588       DO 511 JL = 1, KDLON
    1589       ZW3(JL,1)=0.
    1590       ZW3(JL,2)=0.
    1591       ZW3(JL,3)=0.
    1592       ZW4(JL)  =0.
    1593       ZW5(JL)  =0.
    1594       ZR4(JL)  =1.
    1595       ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
    1596  511  CONTINUE
    1597       DO 514 JK = 1 , KFLEV
    1598       IKL = KFLEV+1-JK
    1599       DO 512 JL = 1, KDLON
    1600       ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
    1601       ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
    1602       ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
    1603       ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
    1604       ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
    1605  512  CONTINUE
    1606 C
    1607       CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
    1608 C
    1609       DO 513 JL = 1, KDLON
    1610 C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
    1611       ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
    1612      S            * ZRJ0(JL,JAJ,IKL)
    1613  513  CONTINUE
    1614  514  CONTINUE
    1615 C
    1616 C
    1617 C*         5.2   UPWARD FLUXES
    1618 C                -------------
    1619 C
    1620  520  CONTINUE
    1621 C
    1622       DO 525 JL = 1, KDLON
    1623       ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
    1624  525  CONTINUE
    1625 C
    1626       DO 528 JK = 2 , KFLEV+1
    1627       IKM1=JK-1
    1628       DO 526 JL = 1, KDLON
    1629       ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
    1630       ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
    1631       ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66
    1632       ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66
    1633       ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66
    1634  526  CONTINUE
    1635 C
    1636       CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
    1637 C
    1638       DO 527 JL = 1, KDLON
    1639 C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
    1640       ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
    1641      S           * ZRK0(JL,JAJ,JK)
    1642  527  CONTINUE
    1643  528  CONTINUE
    1644 C
    1645 C
    1646 C     ------------------------------------------------------------------
    1647 C
    1648 C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
    1649 C                 --------------------------------------------------
    1650 C
    1651  600  CONTINUE
    1652       IABS=3
    1653 C
    1654 C*         6.1    DOWNWARD FLUXES
    1655 C                 ---------------
    1656 C
    1657  610  CONTINUE
    1658       DO 611 JL = 1, KDLON
    1659       ZW1(JL)=0.
    1660       ZW4(JL)=0.
    1661       ZW5(JL)=0.
    1662       ZR1(JL)=0.
    1663       PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)
    1664      S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
    1665  611  CONTINUE
    1666 C
    1667       DO 614 JK = 1 , KFLEV
    1668       IKL=KFLEV+1-JK
    1669       DO 612 JL = 1, KDLON
    1670       ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
    1671       ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
    1672       ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
    1673 C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
    1674  612  CONTINUE
    1675 C
    1676       CALL SWTT(KNU, IABS, ZW1, ZR1)
    1677 C
    1678       DO 613 JL = 1, KDLON
    1679       PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)
    1680      S                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
    1681  613  CONTINUE
    1682  614  CONTINUE
    1683 C
    1684 C
    1685 C*         6.2    UPWARD FLUXES
    1686 C                 -------------
    1687 C
    1688  620  CONTINUE
    1689       DO 621 JL = 1, KDLON
    1690       PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)
    1691      S                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
    1692  621  CONTINUE
    1693 C
    1694       DO 624 JK = 2 , KFLEV+1
    1695       IKM1=JK-1
    1696       DO 622 JL = 1, KDLON
    1697       ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66
    1698       ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
    1699       ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
    1700 C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
    1701  622  CONTINUE
    1702 C
    1703       CALL SWTT(KNU, IABS, ZW1, ZR1)
    1704 C
    1705       DO 623 JL = 1, KDLON
    1706       PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)
    1707      S                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
    1708  623  CONTINUE
    1709  624  CONTINUE
    1710 C
    1711 C     ------------------------------------------------------------------
    1712 C
    1713       RETURN
    1714       END
    1715       SUBROUTINE SWCLR  ( KNU
    1716      S  , PAER  , flag_aer, tauae, pizae, cgae
    1717      S  , PALBP , PDSIG , PRAYL , PSEC
    1718      S  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ 
    1719      S  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )
    1720       USE dimphy
    1721       IMPLICIT none
    1722 cym#include "dimensions.h"
    1723 cym#include "dimphy.h"
    1724 cym#include "raddim.h"
    1725 #include "radepsi.h"
    1726 #include "radopt.h"
    1727 C
    1728 C     ------------------------------------------------------------------
    1729 C     PURPOSE.
    1730 C     --------
    1731 C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
    1732 C     CLEAR-SKY COLUMN
    1733 C
    1734 C     REFERENCE.
    1735 C     ----------
    1736 C
    1737 C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
    1738 C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
    1739 C
    1740 C     AUTHOR.
    1741 C     -------
    1742 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    1743 C
    1744 C     MODIFICATIONS.
    1745 C     --------------
    1746 C        ORIGINAL : 94-11-15
    1747 C     ------------------------------------------------------------------
    1748 C* ARGUMENTS:
    1749 C
    1750       INTEGER KNU
    1751 c-OB
    1752       real*8 flag_aer
    1753       real*8 tauae(kdlon,kflev,2)
    1754       real*8 pizae(kdlon,kflev,2)
    1755       real*8 cgae(kdlon,kflev,2)
    1756       REAL*8 PAER(KDLON,KFLEV,5)
    1757       REAL*8 PALBP(KDLON,2)
    1758       REAL*8 PDSIG(KDLON,KFLEV)
    1759       REAL*8 PRAYL(KDLON)
    1760       REAL*8 PSEC(KDLON)
    1761 C
    1762       REAL*8 PCGAZ(KDLON,KFLEV)     
    1763       REAL*8 PPIZAZ(KDLON,KFLEV)
    1764       REAL*8 PRAY1(KDLON,KFLEV+1)
    1765       REAL*8 PRAY2(KDLON,KFLEV+1)
    1766       REAL*8 PREFZ(KDLON,2,KFLEV+1)
    1767       REAL*8 PRJ(KDLON,6,KFLEV+1)
    1768       REAL*8 PRK(KDLON,6,KFLEV+1)
    1769       REAL*8 PRMU0(KDLON,KFLEV+1)
    1770       REAL*8 PTAUAZ(KDLON,KFLEV)
    1771       REAL*8 PTRA1(KDLON,KFLEV+1)
    1772       REAL*8 PTRA2(KDLON,KFLEV+1)
    1773 C
    1774 C* LOCAL VARIABLES:
    1775 C
    1776       REAL*8 ZC0I(KDLON,KFLEV+1)       
    1777       REAL*8 ZCLE0(KDLON,KFLEV)
    1778       REAL*8 ZCLEAR(KDLON)
    1779       REAL*8 ZR21(KDLON)
    1780       REAL*8 ZR23(KDLON)
    1781       REAL*8 ZSS0(KDLON)
    1782       REAL*8 ZSCAT(KDLON)
    1783       REAL*8 ZTR(KDLON,2,KFLEV+1)
    1784 C
    1785       INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
    1786       REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
    1787       REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
    1788       REAL*8 ZBMU0, ZBMU1, ZRE11
    1789 C
    1790 C* Prescribed Data for Aerosols:
    1791 C
    1792       REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)
    1793       SAVE TAUA, RPIZA, RCGA
    1794 c$OMP THREADPRIVATE(TAUA, RPIZA, RCGA)
    1795       DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /
    1796      S .730719, .912819, .725059, .745405, .682188 ,
    1797      S .730719, .912819, .725059, .745405, .682188 /
    1798       DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /
    1799      S .872212, .982545, .623143, .944887, .997975 ,
    1800      S .872212, .982545, .623143, .944887, .997975 /
    1801       DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /
    1802      S .647596, .739002, .580845, .662657, .624246 ,
    1803      S .647596, .739002, .580845, .662657, .624246 /
    1804 C     ------------------------------------------------------------------
    1805 C
    1806 C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
    1807 C                --------------------------------------------
    1808 C
    1809  100  CONTINUE
    1810 C
    1811       DO 103 JK = 1 , KFLEV+1
    1812       DO 102 JA = 1 , 6
    1813       DO 101 JL = 1, KDLON
    1814       PRJ(JL,JA,JK) = 0.
    1815       PRK(JL,JA,JK) = 0.
    1816  101  CONTINUE
    1817  102  CONTINUE
    1818  103  CONTINUE
    1819 C
    1820       DO 108 JK = 1 , KFLEV
    1821 c-OB
    1822 c      DO 104 JL = 1, KDLON
    1823 c      PCGAZ(JL,JK) = 0.
    1824 c      PPIZAZ(JL,JK) =  0.
    1825 c      PTAUAZ(JL,JK) = 0.
    1826 c 104  CONTINUE
    1827 c-OB
    1828 c      DO 106 JAE=1,5
    1829 c      DO 105 JL = 1, KDLON
    1830 c      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
    1831 c     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
    1832 c      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
    1833 c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
    1834 c      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
    1835 c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
    1836 c 105  CONTINUE
    1837 c 106  CONTINUE
    1838 c-OB
    1839       DO 105 JL = 1, KDLON
    1840       PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
    1841       PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
    1842       PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
    1843  105  CONTINUE
    1844 C
    1845       IF (flag_aer.GT.0) THEN
    1846 c-OB
    1847       DO 107 JL = 1, KDLON
    1848 c         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
    1849 c         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
    1850          ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
    1851          ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
    1852          ZGAR = PCGAZ(JL,JK)
    1853          ZFF = ZGAR * ZGAR
    1854          PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
    1855          PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
    1856          PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
    1857      S                       / (1. - PPIZAZ(JL,JK) * ZFF)
    1858  107  CONTINUE
    1859       ELSE
    1860       DO JL = 1, KDLON
    1861          ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
    1862          PTAUAZ(JL,JK) = ZTRAY
    1863          PCGAZ(JL,JK) = 0.
    1864          PPIZAZ(JL,JK) = 1.-REPSCT
    1865       END DO
    1866       END IF   ! check flag_aer
    1867 c     107  CONTINUE
    1868 c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
    1869 c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
    1870 c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
    1871 C
    1872  108  CONTINUE
    1873 C
    1874 C     ------------------------------------------------------------------
    1875 C
    1876 C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
    1877 C                ----------------------------------------------
    1878 C
    1879  200  CONTINUE
    1880 C
    1881       DO 201 JL = 1, KDLON
    1882       ZR23(JL) = 0.
    1883       ZC0I(JL,KFLEV+1) = 0.
    1884       ZCLEAR(JL) = 1.
    1885       ZSCAT(JL) = 0.
    1886  201  CONTINUE
    1887 C
    1888       JK = 1
    1889       JKL = KFLEV+1 - JK
    1890       JKLP1 = JKL + 1
    1891       DO 202 JL = 1, KDLON
    1892       ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
    1893       ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
    1894       ZR21(JL) = EXP(-ZCORAE   )
    1895       ZSS0(JL) = 1.-ZR21(JL)
    1896       ZCLE0(JL,JKL) = ZSS0(JL)
    1897 C
    1898       IF (NOVLP.EQ.1) THEN
    1899 c* maximum-random
    1900          ZCLEAR(JL) = ZCLEAR(JL)
    1901      S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
    1902      S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
    1903          ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
    1904          ZSCAT(JL) = ZSS0(JL)
    1905       ELSE IF (NOVLP.EQ.2) THEN
    1906 C* maximum
    1907          ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
    1908          ZC0I(JL,JKL) = ZSCAT(JL)
    1909       ELSE IF (NOVLP.EQ.3) THEN
    1910 c* random
    1911          ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
    1912          ZSCAT(JL) = 1.0 - ZCLEAR(JL)
    1913          ZC0I(JL,JKL) = ZSCAT(JL)
    1914       END IF
    1915  202  CONTINUE
    1916 C
    1917       DO 205 JK = 2 , KFLEV
    1918       JKL = KFLEV+1 - JK
    1919       JKLP1 = JKL + 1
    1920       DO 204 JL = 1, KDLON
    1921       ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
    1922       ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
    1923       ZR21(JL) = EXP(-ZCORAE   )
    1924       ZSS0(JL) = 1.-ZR21(JL)
    1925       ZCLE0(JL,JKL) = ZSS0(JL)
    1926 c     
    1927       IF (NOVLP.EQ.1) THEN
    1928 c* maximum-random
    1929          ZCLEAR(JL) = ZCLEAR(JL)
    1930      S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
    1931      S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
    1932          ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
    1933          ZSCAT(JL) = ZSS0(JL)
    1934       ELSE IF (NOVLP.EQ.2) THEN
    1935 C* maximum
    1936          ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
    1937          ZC0I(JL,JKL) = ZSCAT(JL)
    1938       ELSE IF (NOVLP.EQ.3) THEN
    1939 c* random
    1940          ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
    1941          ZSCAT(JL) = 1.0 - ZCLEAR(JL)
    1942          ZC0I(JL,JKL) = ZSCAT(JL)
    1943       END IF                 
    1944  204  CONTINUE
    1945  205  CONTINUE
    1946 C
    1947 C     ------------------------------------------------------------------
    1948 C
    1949 C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
    1950 C                -----------------------------------------------
    1951 C
    1952  300  CONTINUE
    1953 C
    1954       DO 301 JL = 1, KDLON
    1955       PRAY1(JL,KFLEV+1) = 0.
    1956       PRAY2(JL,KFLEV+1) = 0.
    1957       PREFZ(JL,2,1) = PALBP(JL,KNU)
    1958       PREFZ(JL,1,1) = PALBP(JL,KNU)
    1959       PTRA1(JL,KFLEV+1) = 1.
    1960       PTRA2(JL,KFLEV+1) = 1.
    1961  301  CONTINUE
    1962 C
    1963       DO 346 JK = 2 , KFLEV+1
    1964       JKM1 = JK-1
    1965       DO 342 JL = 1, KDLON
    1966 C
    1967 C
    1968 C     ------------------------------------------------------------------
    1969 C
    1970 C*         3.1  EQUIVALENT ZENITH ANGLE
    1971 C               -----------------------
    1972 C
    1973  310  CONTINUE
    1974 C
    1975       ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
    1976      S            + ZC0I(JL,JK) * 1.66
    1977       PRMU0(JL,JK) = 1./ZMUE
    1978 C
    1979 C
    1980 C     ------------------------------------------------------------------
    1981 C
    1982 C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
    1983 C               ----------------------------------------------------
    1984 C
    1985  320  CONTINUE
    1986 C
    1987       ZGAP = PCGAZ(JL,JKM1)
    1988       ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
    1989       ZWW = PPIZAZ(JL,JKM1)
    1990       ZTO = PTAUAZ(JL,JKM1)
    1991       ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
    1992      S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
    1993       PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
    1994       PTRA1(JL,JKM1) = 1. / ZDEN
    1995 C
    1996       ZMU1 = 0.5
    1997       ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
    1998       ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
    1999      S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
    2000       PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
    2001       PTRA2(JL,JKM1) = 1. / ZDEN1
    2002 C
    2003 C
    2004 C
    2005       PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
    2006      S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
    2007      S               * PTRA2(JL,JKM1)
    2008      S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
    2009 C
    2010       ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
    2011      S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
    2012 C
    2013       PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
    2014      S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
    2015      S               * PTRA2(JL,JKM1) )
    2016 C
    2017       ZTR(JL,2,JKM1) = PTRA1(JL,JKM1)
    2018 C
    2019  342  CONTINUE
    2020  346  CONTINUE
    2021       DO 347 JL = 1, KDLON
    2022       ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
    2023       PRMU0(JL,1)=1./ZMUE
    2024  347  CONTINUE
    2025 C
    2026 C
    2027 C     ------------------------------------------------------------------
    2028 C
    2029 C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
    2030 C                 -------------------------------------------------
    2031 C
    2032  350  CONTINUE
    2033 C
    2034       IF (KNU.EQ.1) THEN
    2035       JAJ = 2
    2036       DO 351 JL = 1, KDLON
    2037       PRJ(JL,JAJ,KFLEV+1) = 1.
    2038       PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
    2039  351  CONTINUE
    2040 C
    2041       DO 353 JK = 1 , KFLEV
    2042       JKL = KFLEV+1 - JK
    2043       JKLP1 = JKL + 1
    2044       DO 352 JL = 1, KDLON
    2045       ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
    2046       PRJ(JL,JAJ,JKL) = ZRE11
    2047       PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
    2048  352  CONTINUE
    2049  353  CONTINUE
    2050  354  CONTINUE
    2051 C
    2052       ELSE
    2053 C
    2054       DO 358 JAJ = 1 , 2
    2055       DO 355 JL = 1, KDLON
    2056       PRJ(JL,JAJ,KFLEV+1) = 1.
    2057       PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
    2058  355  CONTINUE
    2059 C
    2060       DO 357 JK = 1 , KFLEV
    2061       JKL = KFLEV+1 - JK
    2062       JKLP1 = JKL + 1
    2063       DO 356 JL = 1, KDLON
    2064       ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
    2065       PRJ(JL,JAJ,JKL) = ZRE11
    2066       PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
    2067  356  CONTINUE
    2068  357  CONTINUE
    2069  358  CONTINUE
    2070 C
    2071       END IF
    2072 C
    2073 C     ------------------------------------------------------------------
    2074 C
    2075       RETURN
    2076       END
    2077       SUBROUTINE SWR ( KNU
    2078      S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL
    2079      S  , PSEC  , PTAU
    2080      S  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE
    2081      S  , PTAUAZ, PTRA1 , PTRA2 )
    2082       USE dimphy
    2083       IMPLICIT none
    2084 cym#include "dimensions.h"
    2085 cym#include "dimphy.h"
    2086 cym#include "raddim.h"
    2087 #include "radepsi.h"
    2088 #include "radopt.h"
    2089 C
    2090 C     ------------------------------------------------------------------
    2091 C     PURPOSE.
    2092 C     --------
    2093 C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
    2094 C     CONTINUUM SCATTERING
    2095 C
    2096 C     METHOD.
    2097 C     -------
    2098 C
    2099 C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
    2100 C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
    2101 C
    2102 C     REFERENCE.
    2103 C     ----------
    2104 C
    2105 C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
    2106 C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
    2107 C
    2108 C     AUTHOR.
    2109 C     -------
    2110 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    2111 C
    2112 C     MODIFICATIONS.
    2113 C     --------------
    2114 C        ORIGINAL : 89-07-14
    2115 C     ------------------------------------------------------------------
    2116 C* ARGUMENTS:
    2117 C
    2118       INTEGER KNU
    2119       REAL*8 PALBD(KDLON,2)
    2120       REAL*8 PCG(KDLON,2,KFLEV)
    2121       REAL*8 PCLD(KDLON,KFLEV)
    2122       REAL*8 PDSIG(KDLON,KFLEV)
    2123       REAL*8 POMEGA(KDLON,2,KFLEV)
    2124       REAL*8 PRAYL(KDLON)
    2125       REAL*8 PSEC(KDLON)
    2126       REAL*8 PTAU(KDLON,2,KFLEV)
    2127 C
    2128       REAL*8 PRAY1(KDLON,KFLEV+1)
    2129       REAL*8 PRAY2(KDLON,KFLEV+1)
    2130       REAL*8 PREFZ(KDLON,2,KFLEV+1)
    2131       REAL*8 PRJ(KDLON,6,KFLEV+1)
    2132       REAL*8 PRK(KDLON,6,KFLEV+1)
    2133       REAL*8 PRMUE(KDLON,KFLEV+1)
    2134       REAL*8 PCGAZ(KDLON,KFLEV)
    2135       REAL*8 PPIZAZ(KDLON,KFLEV)
    2136       REAL*8 PTAUAZ(KDLON,KFLEV)
    2137       REAL*8 PTRA1(KDLON,KFLEV+1)
    2138       REAL*8 PTRA2(KDLON,KFLEV+1)
    2139 C
    2140 C* LOCAL VARIABLES:
    2141 C
    2142       REAL*8 ZC1I(KDLON,KFLEV+1)
    2143       REAL*8 ZCLEQ(KDLON,KFLEV)
    2144       REAL*8 ZCLEAR(KDLON)
    2145       REAL*8 ZCLOUD(KDLON)
    2146       REAL*8 ZGG(KDLON)
    2147       REAL*8 ZREF(KDLON)
    2148       REAL*8 ZRE1(KDLON)
    2149       REAL*8 ZRE2(KDLON)
    2150       REAL*8 ZRMUZ(KDLON)
    2151       REAL*8 ZRNEB(KDLON)
    2152       REAL*8 ZR21(KDLON)
    2153       REAL*8 ZR22(KDLON)
    2154       REAL*8 ZR23(KDLON)
    2155       REAL*8 ZSS1(KDLON)
    2156       REAL*8 ZTO1(KDLON)
    2157       REAL*8 ZTR(KDLON,2,KFLEV+1)
    2158       REAL*8 ZTR1(KDLON)
    2159       REAL*8 ZTR2(KDLON)
    2160       REAL*8 ZW(KDLON)
    2161 C
    2162       INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
    2163       REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
    2164       REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
    2165       REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
    2166 C
    2167 C     ------------------------------------------------------------------
    2168 C
    2169 C*         1.    INITIALIZATION
    2170 C                --------------
    2171 C
    2172  100  CONTINUE
    2173 C
    2174       DO 103 JK = 1 , KFLEV+1
    2175       DO 102 JA = 1 , 6
    2176       DO 101 JL = 1, KDLON
    2177       PRJ(JL,JA,JK) = 0.
    2178       PRK(JL,JA,JK) = 0.
    2179  101  CONTINUE
    2180  102  CONTINUE
    2181  103  CONTINUE
    2182 C
    2183 C
    2184 C     ------------------------------------------------------------------
    2185 C
    2186 C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
    2187 C                ----------------------------------------------
    2188 C
    2189  200  CONTINUE
    2190 C
    2191       DO 201 JL = 1, KDLON
    2192       ZR23(JL) = 0.
    2193       ZC1I(JL,KFLEV+1) = 0.
    2194       ZCLEAR(JL) = 1.
    2195       ZCLOUD(JL) = 0.
    2196  201  CONTINUE
    2197 C
    2198       JK = 1
    2199       JKL = KFLEV+1 - JK
    2200       JKLP1 = JKL + 1
    2201       DO 202 JL = 1, KDLON
    2202       ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
    2203       ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
    2204      S                                 * PCG(JL,KNU,JKL)
    2205       ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
    2206       ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
    2207       ZR21(JL) = EXP(-ZCORAE   )
    2208       ZR22(JL) = EXP(-ZCORCD   )
    2209       ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
    2210      S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
    2211       ZCLEQ(JL,JKL) = ZSS1(JL)
    2212 C
    2213       IF (NOVLP.EQ.1) THEN
    2214 c* maximum-random
    2215          ZCLEAR(JL) = ZCLEAR(JL)
    2216      S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
    2217      S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
    2218          ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
    2219          ZCLOUD(JL) = ZSS1(JL)
    2220       ELSE IF (NOVLP.EQ.2) THEN
    2221 C* maximum
    2222          ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
    2223          ZC1I(JL,JKL) = ZCLOUD(JL)
    2224       ELSE IF (NOVLP.EQ.3) THEN
    2225 c* random
    2226          ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
    2227          ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
    2228          ZC1I(JL,JKL) = ZCLOUD(JL)
    2229       END IF
    2230  202  CONTINUE
    2231 C
    2232       DO 205 JK = 2 , KFLEV
    2233       JKL = KFLEV+1 - JK
    2234       JKLP1 = JKL + 1
    2235       DO 204 JL = 1, KDLON
    2236       ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
    2237       ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
    2238      S                                 * PCG(JL,KNU,JKL)
    2239       ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
    2240       ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
    2241       ZR21(JL) = EXP(-ZCORAE   )
    2242       ZR22(JL) = EXP(-ZCORCD   )
    2243       ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
    2244      S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
    2245       ZCLEQ(JL,JKL) = ZSS1(JL)
    2246 c     
    2247       IF (NOVLP.EQ.1) THEN
    2248 c* maximum-random
    2249          ZCLEAR(JL) = ZCLEAR(JL)
    2250      S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
    2251      S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
    2252          ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
    2253          ZCLOUD(JL) = ZSS1(JL)
    2254       ELSE IF (NOVLP.EQ.2) THEN
    2255 C* maximum
    2256          ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
    2257          ZC1I(JL,JKL) = ZCLOUD(JL)
    2258       ELSE IF (NOVLP.EQ.3) THEN
    2259 c* random
    2260          ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
    2261          ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
    2262          ZC1I(JL,JKL) = ZCLOUD(JL)
    2263       END IF
    2264  204  CONTINUE
    2265  205  CONTINUE
    2266 C
    2267 C     ------------------------------------------------------------------
    2268 C
    2269 C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
    2270 C                -----------------------------------------------
    2271 C
    2272  300  CONTINUE
    2273 C
    2274       DO 301 JL = 1, KDLON
    2275       PRAY1(JL,KFLEV+1) = 0.
    2276       PRAY2(JL,KFLEV+1) = 0.
    2277       PREFZ(JL,2,1) = PALBD(JL,KNU)
    2278       PREFZ(JL,1,1) = PALBD(JL,KNU)
    2279       PTRA1(JL,KFLEV+1) = 1.
    2280       PTRA2(JL,KFLEV+1) = 1.
    2281  301  CONTINUE
    2282 C
    2283       DO 346 JK = 2 , KFLEV+1
    2284       JKM1 = JK-1
    2285       DO 342 JL = 1, KDLON
    2286       ZRNEB(JL)= PCLD(JL,JKM1)
    2287       ZRE1(JL)=0.
    2288       ZTR1(JL)=0.
    2289       ZRE2(JL)=0.
    2290       ZTR2(JL)=0.
    2291 C
    2292 C
    2293 C     ------------------------------------------------------------------
    2294 C
    2295 C*         3.1  EQUIVALENT ZENITH ANGLE
    2296 C               -----------------------
    2297 C
    2298  310  CONTINUE
    2299 C
    2300       ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
    2301      S            + ZC1I(JL,JK) * 1.66
    2302       PRMUE(JL,JK) = 1./ZMUE
    2303 C
    2304 C
    2305 C     ------------------------------------------------------------------
    2306 C
    2307 C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
    2308 C               ----------------------------------------------------
    2309 C
    2310  320  CONTINUE
    2311 C
    2312       ZGAP = PCGAZ(JL,JKM1)
    2313       ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
    2314       ZWW = PPIZAZ(JL,JKM1)
    2315       ZTO = PTAUAZ(JL,JKM1)
    2316       ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
    2317      S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
    2318       PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
    2319       PTRA1(JL,JKM1) = 1. / ZDEN
    2320 c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
    2321 C
    2322       ZMU1 = 0.5
    2323       ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
    2324       ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
    2325      S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
    2326       PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
    2327       PTRA2(JL,JKM1) = 1. / ZDEN1
    2328 C
    2329 C
    2330 C     ------------------------------------------------------------------
    2331 C
    2332 C*         3.3  EFFECT OF CLOUD LAYER
    2333 C               ---------------------
    2334 C
    2335  330  CONTINUE
    2336 C
    2337       ZW(JL) = POMEGA(JL,KNU,JKM1)
    2338       ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
    2339      S         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
    2340       ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
    2341       ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
    2342       ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
    2343      S              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
    2344 C Modif PhD - JJM 19/03/96 pour erreurs arrondis
    2345 C machine
    2346 C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
    2347       IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
    2348          ZW(JL)=1.
    2349       ELSE
    2350          ZW(JL) = ZR21(JL) / ZTO1(JL)
    2351       END IF
    2352       ZREF(JL) = PREFZ(JL,1,JKM1)
    2353       ZRMUZ(JL) = PRMUE(JL,JK)
    2354  342  CONTINUE
    2355 C
    2356       CALL SWDE(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,
    2357      S          ZRE1 , ZRE2  , ZTR1  , ZTR2)
    2358 C
    2359       DO 345 JL = 1, KDLON
    2360 C
    2361       PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
    2362      S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
    2363      S               * PTRA2(JL,JKM1)
    2364      S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
    2365      S               + ZRNEB(JL) * ZRE2(JL)
    2366 C
    2367       ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
    2368      S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
    2369      S               * (1.-ZRNEB(JL))
    2370 C
    2371       PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
    2372      S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
    2373      S               * PTRA2(JL,JKM1) )
    2374      S               + ZRNEB(JL) * ZRE1(JL)
    2375 C
    2376       ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
    2377      S               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
    2378 C
    2379  345  CONTINUE
    2380  346  CONTINUE
    2381       DO 347 JL = 1, KDLON
    2382       ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
    2383       PRMUE(JL,1)=1./ZMUE
    2384  347  CONTINUE
    2385 C
    2386 C
    2387 C     ------------------------------------------------------------------
    2388 C
    2389 C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
    2390 C                 -------------------------------------------------
    2391 C
    2392  350  CONTINUE
    2393 C
    2394       IF (KNU.EQ.1) THEN
    2395       JAJ = 2
    2396       DO 351 JL = 1, KDLON
    2397       PRJ(JL,JAJ,KFLEV+1) = 1.
    2398       PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
    2399  351  CONTINUE
    2400 C
    2401       DO 353 JK = 1 , KFLEV
    2402       JKL = KFLEV+1 - JK
    2403       JKLP1 = JKL + 1
    2404       DO 352 JL = 1, KDLON
    2405       ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
    2406       PRJ(JL,JAJ,JKL) = ZRE11
    2407       PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
    2408  352  CONTINUE
    2409  353  CONTINUE
    2410  354  CONTINUE
    2411 C
    2412       ELSE
    2413 C
    2414       DO 358 JAJ = 1 , 2
    2415       DO 355 JL = 1, KDLON
    2416       PRJ(JL,JAJ,KFLEV+1) = 1.
    2417       PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
    2418  355  CONTINUE
    2419 C
    2420       DO 357 JK = 1 , KFLEV
    2421       JKL = KFLEV+1 - JK
    2422       JKLP1 = JKL + 1
    2423       DO 356 JL = 1, KDLON
    2424       ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
    2425       PRJ(JL,JAJ,JKL) = ZRE11
    2426       PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
    2427  356  CONTINUE
    2428  357  CONTINUE
    2429  358  CONTINUE
    2430 C
    2431       END IF
    2432 C
    2433 C     ------------------------------------------------------------------
    2434 C
    2435       RETURN
    2436       END
    2437       SUBROUTINE SWDE (PGG,PREF,PRMUZ,PTO1,PW,
    2438      S                 PRE1,PRE2,PTR1,PTR2)
    2439       USE dimphy
    2440       IMPLICIT none
    2441 cym#include "dimensions.h"
    2442 cym#include "dimphy.h"
    2443 cym#include "raddim.h"
    2444 C
    2445 C     ------------------------------------------------------------------
    2446 C     PURPOSE.
    2447 C     --------
    2448 C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
    2449 C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
    2450 C
    2451 C     METHOD.
    2452 C     -------
    2453 C
    2454 C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
    2455 C
    2456 C     REFERENCE.
    2457 C     ----------
    2458 C
    2459 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    2460 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    2461 C
    2462 C     AUTHOR.
    2463 C     -------
    2464 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    2465 C
    2466 C     MODIFICATIONS.
    2467 C     --------------
    2468 C        ORIGINAL : 88-12-15
    2469 C     ------------------------------------------------------------------
    2470 C* ARGUMENTS:
    2471 C
    2472       REAL*8 PGG(KDLON)   ! ASSYMETRY FACTOR
    2473       REAL*8 PREF(KDLON)  ! REFLECTIVITY OF THE UNDERLYING LAYER
    2474       REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
    2475       REAL*8 PTO1(KDLON)  ! OPTICAL THICKNESS
    2476       REAL*8 PW(KDLON)    ! SINGLE SCATTERING ALBEDO
    2477       REAL*8 PRE1(KDLON)  ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
    2478       REAL*8 PRE2(KDLON)  ! LAYER REFLECTIVITY
    2479       REAL*8 PTR1(KDLON)  ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
    2480       REAL*8 PTR2(KDLON)  ! LAYER TRANSMISSIVITY
    2481 C
    2482 C* LOCAL VARIABLES:
    2483 C
    2484       INTEGER jl
    2485       REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
    2486       REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
    2487       REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B
    2488       REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
    2489       REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
    2490       REAL*8 ZRI0B, ZRI1B
    2491       REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
    2492       REAL*8 ZRI0C, ZRI1C, ZRI0D, ZRI1D
    2493 C     ------------------------------------------------------------------
    2494 C
    2495 C*         1.      DELTA-EDDINGTON CALCULATIONS
    2496 C
    2497  100  CONTINUE
    2498 C
    2499       DO 131 JL   =   1, KDLON
    2500 C
    2501 C*         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
    2502 C
    2503  110  CONTINUE
    2504 C
    2505       ZFF = PGG(JL)*PGG(JL)
    2506       ZGP = PGG(JL)/(1.+PGG(JL))
    2507       ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
    2508       ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
    2509       ZDT = 2./3.
    2510       ZX1 = 1.-ZWCP*ZGP
    2511       ZWM = 1.-ZWCP
    2512       ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
    2513       ZRK = SQRT(3.*ZWM*ZX1)
    2514       ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
    2515       ZRP=ZRK/ZX1
    2516       ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
    2517       ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
    2518 CMAF      ZARG=MIN(ZTOP/PRMUZ(JL),200.)
    2519       ZARG=MIN(ZTOP/PRMUZ(JL),2.0d+2)
    2520       ZEXMU0=EXP(-ZARG)
    2521 CMAF      ZARG2=MIN(ZRK*ZTOP,200.)
    2522       ZARG2=MIN(ZRK*ZTOP,2.0d+2)
    2523       ZEXKP=EXP(ZARG2)
    2524       ZEXKM = 1./ZEXKP
    2525       ZXP2P = 1.+ZDT*ZRP
    2526       ZXM2P = 1.-ZDT*ZRP
    2527       ZAP2B = ZALPHA+ZDT*ZBETA
    2528       ZAM2B = ZALPHA-ZDT*ZBETA
    2529 C
    2530 C*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
    2531 C
    2532  120  CONTINUE
    2533 C
    2534       ZA11 = ZXP2P
    2535       ZA12 = ZXM2P
    2536       ZA13 = ZAP2B
    2537       ZA22 = ZXP2P*ZEXKP
    2538       ZA21 = ZXM2P*ZEXKM
    2539       ZA23 = ZAM2B*ZEXMU0
    2540       ZDENA = ZA11 * ZA22 - ZA21 * ZA12
    2541       ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
    2542       ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
    2543       ZRI0A = ZC1A+ZC2A-ZALPHA
    2544       ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
    2545       PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
    2546       ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
    2547       ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
    2548       PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
    2549 C
    2550 C*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
    2551 C
    2552  130  CONTINUE
    2553 C
    2554       ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
    2555       ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
    2556       ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
    2557       ZDENB = ZA11 * ZB22 - ZB21 * ZA12
    2558       ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
    2559       ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
    2560       ZRI0C = ZC1B+ZC2B-ZALPHA
    2561       ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
    2562       PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
    2563       ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
    2564       ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
    2565       PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
    2566 C
    2567  131  CONTINUE
    2568       RETURN
    2569       END
    2570       SUBROUTINE SWTT (KNU,KA,PU,PTR)
    2571       USE dimphy
    2572       IMPLICIT none
    2573 cym#include "dimensions.h"
    2574 cym#include "dimphy.h"
    2575 cym#include "raddim.h"
    2576 C
    2577 C-----------------------------------------------------------------------
    2578 C     PURPOSE.
    2579 C     --------
    2580 C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
    2581 C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
    2582 C     INTERVALS.
    2583 C
    2584 C     METHOD.
    2585 C     -------
    2586 C
    2587 C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
    2588 C     AND HORNER'S ALGORITHM.
    2589 C
    2590 C     REFERENCE.
    2591 C     ----------
    2592 C
    2593 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    2594 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    2595 C
    2596 C     AUTHOR.
    2597 C     -------
    2598 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    2599 C
    2600 C     MODIFICATIONS.
    2601 C     --------------
    2602 C        ORIGINAL : 88-12-15
    2603 C-----------------------------------------------------------------------
    2604 C
    2605 C* ARGUMENTS
    2606 C
    2607       INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL
    2608       INTEGER KA      ! INDEX OF THE ABSORBER
    2609       REAL*8 PU(KDLON)  ! ABSORBER AMOUNT
    2610 C
    2611       REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION
    2612 C
    2613 C* LOCAL VARIABLES:
    2614 C
    2615       REAL*8 ZR1(KDLON), ZR2(KDLON)
    2616       INTEGER jl, i,j
    2617 C
    2618 C* Prescribed Data:
    2619 C
    2620       REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
    2621       SAVE APAD, BPAD, D
    2622 c$OMP THREADPRIVATE(APAD, BPAD, D)
    2623       DATA ((APAD(1,I,J),I=1,3),J=1,7) /
    2624      S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
    2625      S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
    2626      S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
    2627      S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
    2628      S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
    2629      S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
    2630      S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
    2631       DATA ((APAD(2,I,J),I=1,3),J=1,7) /
    2632      S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
    2633      S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
    2634      S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
    2635      S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
    2636      S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
    2637      S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
    2638      S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
    2639 C
    2640       DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
    2641      S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
    2642      S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
    2643      S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
    2644      S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
    2645      S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
    2646      S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
    2647      S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
    2648       DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
    2649      S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
    2650      S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
    2651      S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
    2652      S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
    2653      S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
    2654      S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
    2655      S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
    2656 c
    2657       DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
    2658       DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
    2659 C
    2660 C-----------------------------------------------------------------------
    2661 C
    2662 C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
    2663 C
    2664  100  CONTINUE
    2665 C
    2666       DO 201 JL = 1, KDLON
    2667       ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
    2668      S      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
    2669      S      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
    2670      S      * ( APAD(KNU,KA,7) ))))))
    2671 C
    2672       ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
    2673      S      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
    2674      S      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
    2675      S      * ( BPAD(KNU,KA,7) ))))))
    2676 C     
    2677 C
    2678 C*         2.      ADD THE BACKGROUND TRANSMISSION
    2679 C
    2680  200  CONTINUE
    2681 C
    2682 C
    2683       PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
    2684  201  CONTINUE
    2685 C
    2686       RETURN
    2687       END
    2688       SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)
    2689       USE dimphy
    2690       IMPLICIT none
    2691 cym#include "dimensions.h"
    2692 cym#include "dimphy.h"
    2693 cym#include "raddim.h"
    2694 C
    2695 C-----------------------------------------------------------------------
    2696 C     PURPOSE.
    2697 C     --------
    2698 C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
    2699 C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
    2700 C     INTERVALS.
    2701 C
    2702 C     METHOD.
    2703 C     -------
    2704 C
    2705 C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
    2706 C     AND HORNER'S ALGORITHM.
    2707 C
    2708 C     REFERENCE.
    2709 C     ----------
    2710 C
    2711 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    2712 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    2713 C
    2714 C     AUTHOR.
    2715 C     -------
    2716 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    2717 C
    2718 C     MODIFICATIONS.
    2719 C     --------------
    2720 C        ORIGINAL : 95-01-20
    2721 C-----------------------------------------------------------------------
    2722 C* ARGUMENTS:
    2723 C
    2724       INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL
    2725       INTEGER KABS         ! NUMBER OF ABSORBERS
    2726       INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS
    2727       REAL*8 PU(KDLON,KABS)  ! ABSORBER AMOUNT
    2728 C
    2729       REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
    2730 C
    2731 C* LOCAL VARIABLES:
    2732 C
    2733       REAL*8 ZR1(KDLON)
    2734       REAL*8 ZR2(KDLON)
    2735       REAL*8 ZU(KDLON)
    2736       INTEGER jl, ja, i, j, ia
    2737 C
    2738 C* Prescribed Data:
    2739 C
    2740       REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
    2741       SAVE APAD, BPAD, D
    2742 c$OMP THREADPRIVATE(APAD, BPAD, D)
    2743       DATA ((APAD(1,I,J),I=1,3),J=1,7) /
    2744      S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
    2745      S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
    2746      S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
    2747      S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
    2748      S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
    2749      S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
    2750      S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
    2751       DATA ((APAD(2,I,J),I=1,3),J=1,7) /
    2752      S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
    2753      S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
    2754      S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
    2755      S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
    2756      S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
    2757      S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
    2758      S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
    2759 C
    2760       DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
    2761      S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
    2762      S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
    2763      S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
    2764      S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
    2765      S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
    2766      S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
    2767      S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
    2768       DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
    2769      S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
    2770      S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
    2771      S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
    2772      S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
    2773      S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
    2774      S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
    2775      S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
    2776 c
    2777       DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
    2778       DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
    2779 C-----------------------------------------------------------------------
    2780 C
    2781 C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
    2782 C
    2783  100  CONTINUE
    2784 C
    2785       DO 202 JA = 1,KABS
    2786       IA=KIND(JA)
    2787       DO 201 JL = 1, KDLON
    2788       ZU(JL) = PU(JL,JA)
    2789       ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
    2790      S      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
    2791      S      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
    2792      S      * ( APAD(KNU,IA,7) ))))))
    2793 C
    2794       ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
    2795      S      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
    2796      S      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
    2797      S      * ( BPAD(KNU,IA,7) ))))))
    2798 C     
    2799 C
    2800 C*         2.      ADD THE BACKGROUND TRANSMISSION
    2801 C
    2802  200  CONTINUE
    2803 C
    2804       PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA)
    2805  201  CONTINUE
    2806  202  CONTINUE
    2807 C
    2808       RETURN
    2809       END
    2810 cIM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
    2811       SUBROUTINE LW(
    2812      .              PPMB, PDP,
    2813      .              PPSOL,PDT0,PEMIS,
    2814      .              PTL, PTAVE, PWV, POZON, PAER,
    2815      .              PCLDLD,PCLDLU,
    2816      .              PVIEW,
    2817      .              PCOLR, PCOLR0,
    2818      .              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
    2819      .              psollwdown,
    2820 cIM  .              psollwdown,psollwdownclr,
    2821 cIM  .              ptoplwdown,ptoplwdownclr)
    2822      .              plwup, plwdn, plwup0, plwdn0)
    2823       USE dimphy
    2824       IMPLICIT none
    2825 cym#include "dimensions.h"
    2826 cym#include "dimphy.h"
    2827 cym#include "raddim.h"
    2828 #include "raddimlw.h"
    2829 #include "YOMCST.h"
    2830 C
    2831 C-----------------------------------------------------------------------
    2832 C     METHOD.
    2833 C     -------
    2834 C
    2835 C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
    2836 C     ABSORBERS.
    2837 C          2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
    2838 C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
    2839 C          3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
    2840 C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
    2841 C     BOUNDARIES.
    2842 C          4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
    2843 C          5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
    2844 C
    2845 C
    2846 C     REFERENCE.
    2847 C     ----------
    2848 C
    2849 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    2850 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    2851 C
    2852 C     AUTHOR.
    2853 C     -------
    2854 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    2855 C
    2856 C     MODIFICATIONS.
    2857 C     --------------
    2858 C        ORIGINAL : 89-07-14
    2859 C-----------------------------------------------------------------------
    2860 cIM ctes ds clesphys.h
    2861 c     REAL*8 RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
    2862 c     REAL*8 RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
    2863 c     REAL*8 RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
    2864 c     REAL*8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
    2865 c     REAL*8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
    2866 #include "clesphys.h"
    2867       REAL*8 PCLDLD(KDLON,KFLEV)  ! DOWNWARD EFFECTIVE CLOUD COVER
    2868       REAL*8 PCLDLU(KDLON,KFLEV)  ! UPWARD EFFECTIVE CLOUD COVER
    2869       REAL*8 PDP(KDLON,KFLEV)     ! LAYER PRESSURE THICKNESS (Pa)
    2870       REAL*8 PDT0(KDLON)          ! SURFACE TEMPERATURE DISCONTINUITY (K)
    2871       REAL*8 PEMIS(KDLON)         ! SURFACE EMISSIVITY
    2872       REAL*8 PPMB(KDLON,KFLEV+1)  ! HALF LEVEL PRESSURE (mb)
    2873       REAL*8 PPSOL(KDLON)         ! SURFACE PRESSURE (Pa)
    2874       REAL*8 POZON(KDLON,KFLEV)   ! O3 CONCENTRATION (kg/kg)
    2875       REAL*8 PTL(KDLON,KFLEV+1)   ! HALF LEVEL TEMPERATURE (K)
    2876       REAL*8 PAER(KDLON,KFLEV,5)  ! OPTICAL THICKNESS OF THE AEROSOLS
    2877       REAL*8 PTAVE(KDLON,KFLEV)   ! LAYER TEMPERATURE (K)
    2878       REAL*8 PVIEW(KDLON)         ! COSECANT OF VIEWING ANGLE
    2879       REAL*8 PWV(KDLON,KFLEV)     ! SPECIFIC HUMIDITY (kg/kg)
    2880 C
    2881       REAL*8 PCOLR(KDLON,KFLEV)   ! LONG-WAVE TENDENCY (K/day)
    2882       REAL*8 PCOLR0(KDLON,KFLEV)  ! LONG-WAVE TENDENCY (K/day) clear-sky
    2883       REAL*8 PTOPLW(KDLON)        ! LONGWAVE FLUX AT T.O.A.
    2884       REAL*8 PSOLLW(KDLON)        ! LONGWAVE FLUX AT SURFACE
    2885       REAL*8 PTOPLW0(KDLON)       ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
    2886       REAL*8 PSOLLW0(KDLON)       ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
    2887 c Rajout LF
    2888       real*8 psollwdown(kdlon)    ! LONGWAVE downwards flux at surface
    2889 c Rajout IM
    2890 cIM   real*8 psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
    2891 cIM   real*8 ptoplwdown(kdlon)    ! LONGWAVE downwards flux at T.O.A.
    2892 cIM   real*8 ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
    2893 cIM
    2894       REAL*8 plwup(KDLON,KFLEV+1)  ! LW up total sky
    2895       REAL*8 plwup0(KDLON,KFLEV+1) ! LW up clear sky
    2896       REAL*8 plwdn(KDLON,KFLEV+1)  ! LW down total sky
    2897       REAL*8 plwdn0(KDLON,KFLEV+1) ! LW down clear sky
    2898 C-------------------------------------------------------------------------
    2899       REAL*8 ZABCU(KDLON,NUA,3*KFLEV+1)
    2900       REAL*8 ZOZ(KDLON,KFLEV)
    2901 c
    2902 cym      REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
    2903 cym      REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
    2904 cym      REAL*8 ZBINT(KDLON,KFLEV+1)            ! Intermediate variable
    2905 cym      REAL*8 ZBSUI(KDLON)                    ! Intermediate variable
    2906 cym      REAL*8,ZCTS(KDLON,KFLEV)               ! Intermediate variable
    2907 cym      REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate variable
    2908 cym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
    2909       REAL*8,allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
    2910       REAL*8,allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
    2911       REAL*8,allocatable,save :: ZBINT(:,:)            ! Intermediate variable
    2912       REAL*8,allocatable,save :: ZBSUI(:)                    ! Intermediate variable
    2913       REAL*8,allocatable,save :: ZCTS(:,:)               ! Intermediate variable
    2914       REAL*8,allocatable,save :: ZCNTRB(:,:,:)   ! Intermediate variable
    2915 c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
    2916 c
    2917       INTEGER ilim, i, k, kpl1
    2918 C
    2919       INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
    2920       PARAMETER (lw0pas=1)
    2921       INTEGER lwpas  ! Every lwpas steps, cloudy-sky is done
    2922       PARAMETER (lwpas=1)
    2923 c
    2924       INTEGER itaplw0, itaplw
    2925       LOGICAL appel1er
    2926       SAVE appel1er, itaplw0, itaplw
    2927 c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
    2928       DATA appel1er /.TRUE./
    2929       DATA itaplw0,itaplw /0,0/
    2930 
    2931 C     ------------------------------------------------------------------
    2932       IF (appel1er) THEN
    2933          PRINT*, "LW clear-sky calling frequency: ", lw0pas
    2934          PRINT*, "LW cloudy-sky calling frequency: ", lwpas
    2935          PRINT*, "   In general, they should be 1"
    2936 cym
    2937          allocate(ZFLUX(KDLON,2,KFLEV+1) )
    2938          allocate(ZFLUC(KDLON,2,KFLEV+1) )
    2939          allocate(ZBINT(KDLON,KFLEV+1))
    2940          allocate(ZBSUI(KDLON))
    2941          allocate(ZCTS(KDLON,KFLEV))
    2942          allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
    2943          appel1er=.FALSE.
    2944       ENDIF
    2945 C
    2946       IF (MOD(itaplw0,lw0pas).EQ.0) THEN
    2947       DO k = 1, KFLEV  ! convertir ozone de kg/kg en pa/pa
    2948       DO i = 1, KDLON
    2949 c convertir ozone de kg/kg en pa (modif MPL 100505)
    2950          ZOZ(i,k) = POZON(i,k)*PDP(i,k) * RMD/RMO3
    2951 c        print *,'LW: ZOZ*10**6=',ZOZ(i,k)*1000000.
    2952       ENDDO
    2953       ENDDO
    2954 cIM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
    2955       CALL LWU(
    2956      S         PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
    2957       CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
    2958      S          ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
    2959       itaplw0 = 0
    2960       ENDIF
    2961       itaplw0 = itaplw0 + 1
    2962 C
    2963       IF (MOD(itaplw,lwpas).EQ.0) THEN
    2964       CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS,
    2965      S         ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
    2966      S         ZFLUX)
    2967       itaplw = 0
    2968       ENDIF
    2969       itaplw = itaplw + 1
    2970 C
    2971       DO k = 1, KFLEV
    2972          kpl1 = k+1
    2973          DO i = 1, KDLON
    2974             PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
    2975      .                 - ZFLUX(i,1,k)-   ZFLUX(i,2,k)
    2976             PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
    2977             PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
    2978      .                 - ZFLUC(i,1,k)-   ZFLUC(i,2,k)
    2979             PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
    2980          ENDDO
    2981       ENDDO
    2982       DO i = 1, KDLON
    2983          PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
    2984          PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
    2985 c
    2986          PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
    2987          PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
    2988          psollwdown(i) = -ZFLUX(i,2,1)
    2989 c
    2990 cIM attention aux signes !; LWtop >0, LWdn < 0
    2991          DO k = 1, KFLEV+1
    2992            plwup(i,k) = ZFLUX(i,1,k)
    2993            plwup0(i,k) = ZFLUC(i,1,k)
    2994            plwdn(i,k) = ZFLUX(i,2,k)
    2995            plwdn0(i,k) = ZFLUC(i,2,k)
    2996          ENDDO
    2997       ENDDO
    2998 C     ------------------------------------------------------------------
    2999       RETURN
    3000       END
    3001 cIM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
    3002       SUBROUTINE LWU(
    3003      S               PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
    3004      S               PABCU)
    3005       USE dimphy
    3006       IMPLICIT none
    3007 cym#include "dimensions.h"
    3008 cym#include "dimphy.h"
    3009 cym#include "raddim.h"
    3010 #include "raddimlw.h"
    3011 #include "YOMCST.h"
    3012 #include "radepsi.h"
    3013 #include "radopt.h"
    3014 C
    3015 C     PURPOSE.
    3016 C     --------
    3017 C           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
    3018 C           TEMPERATURE EFFECTS
    3019 C
    3020 C     METHOD.
    3021 C     -------
    3022 C
    3023 C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
    3024 C     ABSORBERS.
    3025 C
    3026 C
    3027 C     REFERENCE.
    3028 C     ----------
    3029 C
    3030 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    3031 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    3032 C
    3033 C     AUTHOR.
    3034 C     -------
    3035 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    3036 C
    3037 C     MODIFICATIONS.
    3038 C     --------------
    3039 C        ORIGINAL : 89-07-14
    3040 C        Voigt lines (loop 404 modified) - JJM & PhD - 01/96
    3041 C-----------------------------------------------------------------------
    3042 C* ARGUMENTS:
    3043 cIM ctes ds clesphys.h
    3044 c     REAL*8 RCO2
    3045 c     REAL*8 RCH4, RN2O, RCFC11, RCFC12
    3046 #include "clesphys.h"
    3047       REAL*8 PAER(KDLON,KFLEV,5)
    3048       REAL*8 PDP(KDLON,KFLEV)
    3049       REAL*8 PPMB(KDLON,KFLEV+1)
    3050       REAL*8 PPSOL(KDLON)
    3051       REAL*8 POZ(KDLON,KFLEV)
    3052       REAL*8 PTAVE(KDLON,KFLEV)
    3053       REAL*8 PVIEW(KDLON)
    3054       REAL*8 PWV(KDLON,KFLEV)
    3055 C
    3056       REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
    3057 C
    3058 C-----------------------------------------------------------------------
    3059 C* LOCAL VARIABLES:
    3060       REAL*8 ZABLY(KDLON,NUA,3*KFLEV+1)
    3061       REAL*8 ZDUC(KDLON,3*KFLEV+1)
    3062       REAL*8 ZPHIO(KDLON)
    3063       REAL*8 ZPSC2(KDLON)
    3064       REAL*8 ZPSC3(KDLON)
    3065       REAL*8 ZPSH1(KDLON)
    3066       REAL*8 ZPSH2(KDLON)
    3067       REAL*8 ZPSH3(KDLON)
    3068       REAL*8 ZPSH4(KDLON)
    3069       REAL*8 ZPSH5(KDLON)
    3070       REAL*8 ZPSH6(KDLON)
    3071       REAL*8 ZPSIO(KDLON)
    3072       REAL*8 ZTCON(KDLON)
    3073       REAL*8 ZPHM6(KDLON)
    3074       REAL*8 ZPSM6(KDLON)
    3075       REAL*8 ZPHN6(KDLON)
    3076       REAL*8 ZPSN6(KDLON)
    3077       REAL*8 ZSSIG(KDLON,3*KFLEV+1)
    3078       REAL*8 ZTAVI(KDLON)
    3079       REAL*8 ZUAER(KDLON,Ninter)
    3080       REAL*8 ZXOZ(KDLON)
    3081       REAL*8 ZXWV(KDLON)
    3082 C
    3083       INTEGER jl, jk, jkj, jkjr, jkjp, ig1
    3084       INTEGER jki, jkip1, ja, jj
    3085       INTEGER jkl, jkp1, jkk, jkjpn
    3086       INTEGER jae1, jae2, jae3, jae, jjpn
    3087       INTEGER ir, jc, jcp1
    3088       REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
    3089       REAL*8 zfppw, ztx, ztx2, zzably
    3090       REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
    3091       REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
    3092       REAL*8 zcac8, zcbc8
    3093       REAL*8 zalup, zdiff
    3094 c
    3095       REAL*8 PVGCO2, PVGH2O, PVGO3
    3096 C
    3097       REAL*8 R10E  ! DECIMAL/NATURAL LOG.FACTOR
    3098       PARAMETER (R10E=0.4342945)
    3099 c
    3100 c Used Data Block:
    3101 c
    3102       REAL*8 TREF
    3103       SAVE TREF
    3104 c$OMP THREADPRIVATE(TREF)
    3105       REAL*8 RT1(2)
    3106       SAVE RT1
    3107 c$OMP THREADPRIVATE(RT1)
    3108       REAL*8 RAER(5,5)
    3109       SAVE RAER
    3110 c$OMP THREADPRIVATE(RAER)
    3111       REAL*8 AT(8,3), BT(8,3)
    3112       SAVE AT, BT
    3113 c$OMP THREADPRIVATE(AT, BT)
    3114       REAL*8 OCT(4)
    3115       SAVE OCT
    3116 c$OMP THREADPRIVATE(OCT)
    3117       DATA TREF /250.0/
    3118       DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
    3119       DATA RAER / .038520, .037196, .040532, .054934, .038520
    3120      1          , .12613 , .18313 , .10357 , .064106, .126130
    3121      2          , .012579, .013649, .018652, .025181, .012579
    3122      3          , .011890, .016142, .021105, .028908, .011890
    3123      4          , .013792, .026810, .052203, .066338, .013792 /
    3124       DATA (AT(1,IR),IR=1,3) /
    3125      S 0.298199E-02,-.394023E-03,0.319566E-04 /
    3126       DATA (BT(1,IR),IR=1,3) /
    3127      S-0.106432E-04,0.660324E-06,0.174356E-06 /
    3128       DATA (AT(2,IR),IR=1,3) /
    3129      S 0.143676E-01,0.366501E-02,-.160822E-02 /
    3130       DATA (BT(2,IR),IR=1,3) /
    3131      S-0.553979E-04,-.101701E-04,0.920868E-05 /
    3132       DATA (AT(3,IR),IR=1,3) /
    3133      S 0.197861E-01,0.315541E-02,-.174547E-02 /
    3134       DATA (BT(3,IR),IR=1,3) /
    3135      S-0.877012E-04,0.513302E-04,0.523138E-06 /
    3136       DATA (AT(4,IR),IR=1,3) /
    3137      S 0.289560E-01,-.208807E-02,-.121943E-02 /
    3138       DATA (BT(4,IR),IR=1,3) /
    3139      S-0.165960E-03,0.157704E-03,-.146427E-04 /
    3140       DATA (AT(5,IR),IR=1,3) /
    3141      S 0.103800E-01,0.436296E-02,-.161431E-02 /
    3142       DATA (BT(5,IR),IR=1,3) /
    3143      S -.276744E-04,-.327381E-04,0.127646E-04 /
    3144       DATA (AT(6,IR),IR=1,3) /
    3145      S 0.868859E-02,-.972752E-03,0.000000E-00 /
    3146       DATA (BT(6,IR),IR=1,3) /
    3147      S -.278412E-04,-.713940E-06,0.117469E-05 /
    3148       DATA (AT(7,IR),IR=1,3) /
    3149      S 0.250073E-03,0.455875E-03,0.109242E-03 /
    3150       DATA (BT(7,IR),IR=1,3) /
    3151      S 0.199846E-05,-.216313E-05,0.175991E-06 /
    3152       DATA (AT(8,IR),IR=1,3) /
    3153      S 0.307423E-01,0.110879E-02,-.322172E-03 /
    3154       DATA (BT(8,IR),IR=1,3) /
    3155      S-0.108482E-03,0.258096E-05,-.814575E-06 /
    3156 c
    3157       DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
    3158 C-----------------------------------------------------------------------
    3159 c
    3160       IF (LEVOIGT) THEN
    3161          PVGCO2= 60.
    3162          PVGH2O= 30.
    3163          PVGO3 =400.
    3164       ELSE
    3165          PVGCO2= 0.
    3166          PVGH2O= 0.
    3167          PVGO3 = 0.
    3168       ENDIF
    3169 C
    3170 C
    3171 C*         2.    PRESSURE OVER GAUSS SUB-LEVELS
    3172 C                ------------------------------
    3173 C
    3174  200  CONTINUE
    3175 C
    3176       DO 201 JL = 1, KDLON
    3177       ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
    3178  201  CONTINUE
    3179 C
    3180       DO 206 JK = 1 , KFLEV
    3181       JKJ=(JK-1)*NG1P1+1
    3182       JKJR = JKJ
    3183       JKJP = JKJ + NG1P1
    3184       DO 203 JL = 1, KDLON
    3185       ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
    3186  203  CONTINUE
    3187       DO 205 IG1=1,NG1
    3188       JKJ=JKJ+1
    3189       DO 204 JL = 1, KDLON
    3190       ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
    3191      S  + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
    3192  204  CONTINUE
    3193  205  CONTINUE
    3194  206  CONTINUE
    3195 C
    3196 C-----------------------------------------------------------------------
    3197 C
    3198 C
    3199 C*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
    3200 C                --------------------------------------------------
    3201 C
    3202  400  CONTINUE
    3203 C
    3204       DO 402 JKI=1,3*KFLEV
    3205       JKIP1=JKI+1
    3206       DO 401 JL = 1, KDLON
    3207       ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
    3208       ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
    3209      S                                 /(10.*RG)
    3210  401  CONTINUE
    3211  402  CONTINUE
    3212 C
    3213       DO 406 JK = 1 , KFLEV
    3214       JKP1=JK+1
    3215       JKL = KFLEV+1 - JK
    3216       DO 403 JL = 1, KDLON
    3217       ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
    3218       ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
    3219  403  CONTINUE
    3220       JKJ=(JK-1)*NG1P1+1
    3221       JKJPN=JKJ+NG1
    3222       DO 405 JKK=JKJ,JKJPN
    3223       DO 404 JL = 1, KDLON
    3224       ZDPM = ZABLY(JL,3,JKK)
    3225       ZUPM = ZABLY(JL,5,JKK)             * ZDPM / 101325.
    3226       ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
    3227       ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
    3228       ZUPMO3  = ( ZABLY(JL,5,JKK) + PVGO3  ) * ZDPM / 101325.
    3229       ZDUC(JL,JKK) = ZDPM
    3230       ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
    3231       ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
    3232       ZU6 = ZXWV(JL) * ZUPM
    3233       ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
    3234       ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
    3235       ZABLY(JL,11,JKK) = ZU6 * ZFPPW
    3236       ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
    3237       ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
    3238       ZABLY(JL,8,JKK) = RCO2 * ZDPM
    3239  404  CONTINUE
    3240  405  CONTINUE
    3241  406  CONTINUE
    3242 C
    3243 C-----------------------------------------------------------------------
    3244 C
    3245 C
    3246 C*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
    3247 C                --------------------------------------------------
    3248 C
    3249  500  CONTINUE
    3250 C
    3251       DO 502 JA = 1, NUA
    3252       DO 501 JL = 1, KDLON
    3253       PABCU(JL,JA,3*KFLEV+1) = 0.
    3254   501 CONTINUE
    3255   502 CONTINUE
    3256 C
    3257       DO 529 JK = 1 , KFLEV
    3258       JJ=(JK-1)*NG1P1+1
    3259       JJPN=JJ+NG1
    3260       JKL=KFLEV+1-JK
    3261 C
    3262 C
    3263 C*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
    3264 C               --------------------------------------------------
    3265 C
    3266  510  CONTINUE
    3267 C
    3268       JAE1=3*KFLEV+1-JJ
    3269       JAE2=3*KFLEV+1-(JJ+1)
    3270       JAE3=3*KFLEV+1-JJPN
    3271       DO 512 JAE=1,5
    3272       DO 511 JL = 1, KDLON
    3273       ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
    3274      S      +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)
    3275      S      +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))
    3276      S      /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
    3277  511  CONTINUE
    3278  512  CONTINUE
    3279 C
    3280 C
    3281 C
    3282 C*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
    3283 C               --------------------------------------------------
    3284 C
    3285  520  CONTINUE
    3286 C
    3287       DO 521 JL = 1, KDLON
    3288       ZTAVI(JL)=PTAVE(JL,JKL)
    3289       ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
    3290       ZTX=ZTAVI(JL)-TREF
    3291       ZTX2=ZTX*ZTX
    3292       ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
    3293 CMAF      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.), 6.0)
    3294       ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.d+0), 6.d+0)
    3295       ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
    3296       ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
    3297       ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
    3298       ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
    3299       ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
    3300       ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
    3301       ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
    3302       ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
    3303       ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
    3304       ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
    3305       ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
    3306       ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
    3307       ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
    3308       ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
    3309       ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
    3310       ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
    3311       ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
    3312       ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
    3313       ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
    3314       ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
    3315       ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
    3316       ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
    3317  521  CONTINUE
    3318 C
    3319       DO 522 JL = 1, KDLON
    3320       ZTAVI(JL)=PTAVE(JL,JKL)
    3321       ZTX=ZTAVI(JL)-TREF
    3322       ZTX2=ZTX*ZTX
    3323       ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
    3324       ZALUP = R10E * LOG ( ZZABLY )
    3325 CMAF      ZUP   = MAX( 0.0 , 5.0 + 0.5 * ZALUP )
    3326       ZUP   = MAX( 0.d+0 , 5.0 + 0.5 * ZALUP )
    3327       ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
    3328       ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
    3329       ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
    3330       ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
    3331       ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
    3332       ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
    3333  522  CONTINUE
    3334 C
    3335       DO 524 JKK=JJ,JJPN
    3336       JC=3*KFLEV+1-JKK
    3337       JCP1=JC+1
    3338       DO 523 JL = 1, KDLON
    3339       ZDIFF = PVIEW(JL)
    3340       PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
    3341      S                +ZABLY(JL,10,JC)           *ZDIFF
    3342       PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
    3343      S                +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
    3344 C
    3345       PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
    3346      S                +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
    3347       PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
    3348      S                +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
    3349 C
    3350       PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
    3351      S               +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
    3352       PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
    3353      S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
    3354       PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
    3355      S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
    3356 C
    3357       PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
    3358      S               +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
    3359       PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
    3360      S               +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
    3361       PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
    3362      S               +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
    3363       PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
    3364      S               +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
    3365       PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
    3366      S               +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
    3367       PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
    3368      S               +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
    3369 C
    3370       PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
    3371      S                +ZUAER(JL,1)    *ZDUC(JL,JC)*ZDIFF
    3372       PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
    3373      S                +ZUAER(JL,2)    *ZDUC(JL,JC)*ZDIFF
    3374       PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
    3375      S                +ZUAER(JL,3)    *ZDUC(JL,JC)*ZDIFF
    3376       PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
    3377      S                +ZUAER(JL,4)    *ZDUC(JL,JC)*ZDIFF
    3378       PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
    3379      S                +ZUAER(JL,5)    *ZDUC(JL,JC)*ZDIFF
    3380 C
    3381       PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
    3382      S               +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
    3383       PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
    3384      S               +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
    3385       PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
    3386      S               +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
    3387       PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
    3388      S               +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
    3389 C
    3390       PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
    3391      S               +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
    3392       PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
    3393      S               +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
    3394  523  CONTINUE
    3395  524  CONTINUE
    3396 C
    3397  529  CONTINUE
    3398 C
    3399 C
    3400       RETURN
    3401       END
    3402       SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
    3403      S                PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
    3404       USE dimphy
    3405       IMPLICIT none
    3406 cym#include "dimensions.h"
    3407 cym#include "dimphy.h"
    3408 cym#include "raddim.h"
    3409 #include "raddimlw.h"
    3410 #include "YOMCST.h"
    3411 C
    3412 C     PURPOSE.
    3413 C     --------
    3414 C           TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
    3415 C           VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
    3416 C           SAVING
    3417 C
    3418 C     METHOD.
    3419 C     -------
    3420 C
    3421 C          1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
    3422 C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
    3423 C          2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
    3424 C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
    3425 C     BOUNDARIES.
    3426 C          3. COMPUTES THE CLEAR-SKY COOLING RATES.
    3427 C
    3428 C     REFERENCE.
    3429 C     ----------
    3430 C
    3431 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    3432 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    3433 C
    3434 C     AUTHOR.
    3435 C     -------
    3436 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    3437 C
    3438 C     MODIFICATIONS.
    3439 C     --------------
    3440 C        ORIGINAL : 89-07-14
    3441 C        MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
    3442 C                                          MEMORY)
    3443 C-----------------------------------------------------------------------
    3444 C* ARGUMENTS:
    3445       INTEGER KLIM
    3446 C
    3447       REAL*8 PDP(KDLON,KFLEV)
    3448       REAL*8 PDT0(KDLON)
    3449       REAL*8 PEMIS(KDLON)
    3450       REAL*8 PPMB(KDLON,KFLEV+1)
    3451       REAL*8 PTL(KDLON,KFLEV+1)
    3452       REAL*8 PTAVE(KDLON,KFLEV)
    3453 C
    3454       REAL*8 PFLUC(KDLON,2,KFLEV+1)
    3455 C     
    3456       REAL*8 PABCU(KDLON,NUA,3*KFLEV+1)
    3457       REAL*8 PBINT(KDLON,KFLEV+1)
    3458       REAL*8 PBSUI(KDLON)
    3459       REAL*8 PCTS(KDLON,KFLEV)
    3460       REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
    3461 C
    3462 C-------------------------------------------------------------------------
    3463 C
    3464 C* LOCAL VARIABLES:
    3465       REAL*8 ZB(KDLON,Ninter,KFLEV+1)
    3466       REAL*8 ZBSUR(KDLON,Ninter)
    3467       REAL*8 ZBTOP(KDLON,Ninter)
    3468       REAL*8 ZDBSL(KDLON,Ninter,KFLEV*2)
    3469       REAL*8 ZGA(KDLON,8,2,KFLEV)
    3470       REAL*8 ZGB(KDLON,8,2,KFLEV)
    3471       REAL*8 ZGASUR(KDLON,8,2)
    3472       REAL*8 ZGBSUR(KDLON,8,2)
    3473       REAL*8 ZGATOP(KDLON,8,2)
    3474       REAL*8 ZGBTOP(KDLON,8,2)
    3475 C
    3476       INTEGER nuaer, ntraer
    3477 C     ------------------------------------------------------------------
    3478 C* COMPUTES PLANCK FUNCTIONS:
    3479        CALL LWB(PDT0,PTAVE,PTL,
    3480      S          ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
    3481      S          ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
    3482 C     ------------------------------------------------------------------
    3483 C* PERFORMS THE VERTICAL INTEGRATION:
    3484       NUAER = NUA
    3485       NTRAER = NTRA
    3486       CALL LWV(NUAER,NTRAER, KLIM
    3487      R  , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
    3488      R  , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
    3489      S  , PCNTRB,PCTS,PFLUC)
    3490 C     ------------------------------------------------------------------
    3491       RETURN
    3492       END
    3493       SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
    3494      R               PBINT,PBSUIN,PCTS,PCNTRB,
    3495      S               PFLUX)
    3496       USE dimphy
    3497       IMPLICIT none
    3498 cym#include "dimensions.h"
    3499 cym#include "dimphy.h"
    3500 cym#include "raddim.h"
    3501 #include "radepsi.h"
    3502 #include "radopt.h"
    3503 C
    3504 C     PURPOSE.
    3505 C     --------
    3506 C           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
    3507 C           RADIANCES
    3508 C
    3509 C        EXPLICIT ARGUMENTS :
    3510 C        --------------------
    3511 C     ==== INPUTS ===
    3512 C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
    3513 C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
    3514 C PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
    3515 C PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
    3516 C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
    3517 C PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
    3518 C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
    3519 C PFLUC
    3520 C     ==== OUTPUTS ===
    3521 C PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
    3522 C                     1  ==>  UPWARD   FLUX TOTAL
    3523 C                     2  ==>  DOWNWARD FLUX TOTAL
    3524 C
    3525 C     METHOD.
    3526 C     -------
    3527 C
    3528 C          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
    3529 C          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
    3530 C          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
    3531 C     CLOUDS
    3532 C
    3533 C     REFERENCE.
    3534 C     ----------
    3535 C
    3536 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    3537 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    3538 C
    3539 C     AUTHOR.
    3540 C     -------
    3541 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    3542 C
    3543 C     MODIFICATIONS.
    3544 C     --------------
    3545 C        ORIGINAL : 89-07-14
    3546 C        Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
    3547 C-----------------------------------------------------------------------
    3548 C* ARGUMENTS:
    3549       INTEGER klim
    3550       REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
    3551       REAL*8 PBINT(KDLON,KFLEV+1)   ! HALF LEVEL PLANCK FUNCTION
    3552       REAL*8 PBSUIN(KDLON)          ! SURFACE PLANCK FUNCTION
    3553       REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
    3554       REAL*8 PCTS(KDLON,KFLEV)      ! CLEAR-SKY LAYER COOLING-TO-SPACE
    3555 c
    3556       REAL*8 PCLDLD(KDLON,KFLEV)
    3557       REAL*8 PCLDLU(KDLON,KFLEV)
    3558       REAL*8 PEMIS(KDLON)
    3559 C
    3560       REAL*8 PFLUX(KDLON,2,KFLEV+1)
    3561 C-----------------------------------------------------------------------
    3562 C* LOCAL VARIABLES:
    3563       INTEGER IMX(KDLON), IMXP(KDLON)
    3564 C
    3565       REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
    3566      S  , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
    3567      S  , ZUPF(KDLON,KFLEV+1,KFLEV+1)
    3568       REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
    3569 C
    3570       INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
    3571       INTEGER jk1, jk2, jkc, jkcp1, jcloud
    3572       INTEGER imxm1, imxp1
    3573       REAL*8 zcfrac
    3574 C     ------------------------------------------------------------------
    3575 C
    3576 C*         1.     INITIALIZATION
    3577 C                 --------------
    3578 C
    3579  100  CONTINUE
    3580 C
    3581       IMAXC = 0
    3582 C
    3583       DO 101 JL = 1, KDLON
    3584       IMX(JL)=0
    3585       IMXP(JL)=0
    3586       ZCLOUD(JL) = 0.
    3587  101  CONTINUE
    3588 C
    3589 C*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
    3590 C                 -------------------------------------------
    3591 C
    3592  110  CONTINUE
    3593 C
    3594       DO 112 JK = 1 , KFLEV
    3595       DO 111 JL = 1, KDLON
    3596       IMX1=IMX(JL)
    3597       IMX2=JK
    3598       IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
    3599          IMXP(JL)=IMX2
    3600       ELSE
    3601          IMXP(JL)=IMX1
    3602       END IF
    3603       IMAXC=MAX(IMXP(JL),IMAXC)
    3604       IMX(JL)=IMXP(JL)
    3605  111  CONTINUE
    3606  112  CONTINUE
    3607 CGM*******
    3608       IMAXC=KFLEV
    3609 CGM*******
    3610 C
    3611       DO 114 JK = 1 , KFLEV+1
    3612       DO 113 JL = 1, KDLON
    3613       PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
    3614       PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
    3615  113  CONTINUE
    3616  114  CONTINUE
    3617 C
    3618 C     ------------------------------------------------------------------
    3619 C
    3620 C*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
    3621 C                  ---------------------------------------
    3622 C
    3623       IF (IMAXC.GT.0) THEN
    3624 C
    3625          IMXP1 = IMAXC + 1
    3626          IMXM1 = IMAXC - 1
    3627 C
    3628 C*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
    3629 C                  ------------------------------
    3630 C
    3631  200  CONTINUE
    3632 C
    3633          DO 203 JK1=1,KFLEV+1
    3634          DO 202 JK2=1,KFLEV+1
    3635          DO 201 JL = 1, KDLON
    3636          ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
    3637          ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
    3638  201     CONTINUE
    3639  202     CONTINUE
    3640  203     CONTINUE
    3641 C
    3642 C*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
    3643 C                  ----------------------------------------------
    3644 C
    3645  210  CONTINUE
    3646 C
    3647          DO 213 JKC = 1 , IMAXC
    3648          JCLOUD=JKC
    3649          JKCP1=JCLOUD+1
    3650 C
    3651 C*         2.1.1   ABOVE THE CLOUD
    3652 C                  ---------------
    3653 C
    3654  2110 CONTINUE
    3655 C
    3656          DO 2115 JK=JKCP1,KFLEV+1
    3657          JKM1=JK-1
    3658          DO 2111 JL = 1, KDLON
    3659          ZFU(JL)=0.
    3660  2111    CONTINUE
    3661          IF (JK .GT. JKCP1) THEN
    3662             DO 2113 JKJ=JKCP1,JKM1
    3663             DO 2112 JL = 1, KDLON
    3664             ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
    3665  2112       CONTINUE
    3666  2113       CONTINUE
    3667          END IF
    3668 C
    3669          DO 2114 JL = 1, KDLON
    3670          ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
    3671  2114    CONTINUE
    3672  2115    CONTINUE
    3673 C
    3674 C*         2.1.2   BELOW THE CLOUD
    3675 C                  ---------------
    3676 C
    3677  2120 CONTINUE
    3678 C
    3679          DO 2125 JK=1,JCLOUD
    3680          JKP1=JK+1
    3681          DO 2121 JL = 1, KDLON
    3682          ZFD(JL)=0.
    3683  2121    CONTINUE
    3684 C
    3685          IF (JK .LT. JCLOUD) THEN
    3686             DO 2123 JKJ=JKP1,JCLOUD
    3687             DO 2122 JL = 1, KDLON
    3688             ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
    3689  2122       CONTINUE
    3690  2123       CONTINUE
    3691          END IF
    3692          DO 2124 JL = 1, KDLON
    3693          ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
    3694  2124    CONTINUE
    3695  2125    CONTINUE
    3696 C
    3697  213     CONTINUE
    3698 C
    3699 C
    3700 C*         2.2     CLOUD COVER MATRIX
    3701 C                  ------------------
    3702 C
    3703 C*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
    3704 C     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
    3705 C
    3706  220  CONTINUE
    3707 C
    3708       DO 223 JK1 = 1 , KFLEV+1
    3709       DO 222 JK2 = 1 , KFLEV+1
    3710       DO 221 JL = 1, KDLON
    3711       ZCLM(JL,JK1,JK2) = 0.
    3712  221  CONTINUE
    3713  222  CONTINUE
    3714  223  CONTINUE
    3715 C
    3716 C
    3717 C
    3718 C*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
    3719 C                  ------------------------------------------
    3720 C
    3721  240  CONTINUE
    3722 C
    3723       DO 244 JK1 = 2 , KFLEV+1
    3724       DO 241 JL = 1, KDLON
    3725       ZCLEAR(JL)=1.
    3726       ZCLOUD(JL)=0.
    3727  241  CONTINUE
    3728       DO 243 JK = JK1 - 1 , 1 , -1
    3729       DO 242 JL = 1, KDLON
    3730       IF (NOVLP.EQ.1) THEN
    3731 c* maximum-random       
    3732          ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
    3733      *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
    3734          ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
    3735          ZCLOUD(JL) = PCLDLU(JL,JK)
    3736       ELSE IF (NOVLP.EQ.2) THEN
    3737 c* maximum     
    3738          ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
    3739          ZCLM(JL,JK1,JK) = ZCLOUD(JL)
    3740       ELSE IF (NOVLP.EQ.3) THEN
    3741 c* random     
    3742          ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
    3743          ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
    3744          ZCLM(JL,JK1,JK) = ZCLOUD(JL)
    3745       END IF
    3746  242  CONTINUE
    3747  243  CONTINUE
    3748  244  CONTINUE
    3749 C
    3750 C
    3751 C*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
    3752 C                  ------------------------------------------
    3753 C
    3754  250  CONTINUE
    3755 C
    3756       DO 254 JK1 = 1 , KFLEV
    3757       DO 251 JL = 1, KDLON
    3758       ZCLEAR(JL)=1.
    3759       ZCLOUD(JL)=0.
    3760  251  CONTINUE
    3761       DO 253 JK = JK1 , KFLEV
    3762       DO 252 JL = 1, KDLON
    3763       IF (NOVLP.EQ.1) THEN
    3764 c* maximum-random       
    3765          ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
    3766      *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
    3767          ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
    3768          ZCLOUD(JL) = PCLDLD(JL,JK)
    3769       ELSE IF (NOVLP.EQ.2) THEN
    3770 c* maximum     
    3771          ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
    3772          ZCLM(JL,JK1,JK) = ZCLOUD(JL)
    3773       ELSE IF (NOVLP.EQ.3) THEN
    3774 c* random     
    3775          ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
    3776          ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
    3777          ZCLM(JL,JK1,JK) = ZCLOUD(JL)
    3778       END IF
    3779  252  CONTINUE
    3780  253  CONTINUE
    3781  254  CONTINUE
    3782 C
    3783 C
    3784 C
    3785 C*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
    3786 C                  ----------------------------------------------
    3787 C
    3788  300  CONTINUE
    3789 C
    3790 C*         3.1     DOWNWARD FLUXES
    3791 C                  ---------------
    3792 C
    3793  310  CONTINUE
    3794 C
    3795       DO 311 JL = 1, KDLON
    3796       PFLUX(JL,2,KFLEV+1) = 0.
    3797  311  CONTINUE
    3798 C
    3799       DO 317 JK1 = KFLEV , 1 , -1
    3800 C
    3801 C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
    3802 C
    3803       DO 312 JL = 1, KDLON
    3804       ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
    3805  312  CONTINUE
    3806 C
    3807 C*                 CONTRIBUTION FROM ADJACENT CLOUD
    3808 C
    3809       DO 313 JL = 1, KDLON
    3810       ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
    3811  313  CONTINUE
    3812 C
    3813 C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
    3814 C
    3815       DO 315 JK = KFLEV-1 , JK1 , -1
    3816       DO 314 JL = 1, KDLON
    3817       ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
    3818       ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
    3819  314  CONTINUE
    3820  315  CONTINUE
    3821 C
    3822       DO 316 JL = 1, KDLON
    3823       PFLUX(JL,2,JK1) = ZFD (JL)
    3824  316  CONTINUE
    3825 C
    3826  317  CONTINUE
    3827 C
    3828 C
    3829 C
    3830 C
    3831 C*         3.2     UPWARD FLUX AT THE SURFACE
    3832 C                  --------------------------
    3833 C
    3834  320  CONTINUE
    3835 C
    3836       DO 321 JL = 1, KDLON
    3837       PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
    3838  321  CONTINUE
    3839 C
    3840 C
    3841 C
    3842 C*         3.3     UPWARD FLUXES
    3843 C                  -------------
    3844 C
    3845  330  CONTINUE
    3846 C
    3847       DO 337 JK1 = 2 , KFLEV+1
    3848 C
    3849 C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
    3850 C
    3851       DO 332 JL = 1, KDLON
    3852       ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
    3853  332  CONTINUE
    3854 C
    3855 C*                 CONTRIBUTION FROM ADJACENT CLOUD
    3856 C
    3857       DO 333 JL = 1, KDLON
    3858       ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
    3859  333  CONTINUE
    3860 C
    3861 C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
    3862 C
    3863       DO 335 JK = 2 , JK1-1
    3864       DO 334 JL = 1, KDLON
    3865       ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
    3866       ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
    3867  334  CONTINUE
    3868  335  CONTINUE
    3869 C
    3870       DO 336 JL = 1, KDLON
    3871       PFLUX(JL,1,JK1) = ZFU (JL)
    3872  336  CONTINUE
    3873 C
    3874  337  CONTINUE
    3875 C
    3876 C
    3877       END IF
    3878 C
    3879 C
    3880 C*         2.3     END OF CLOUD EFFECT COMPUTATIONS
    3881 C
    3882  230  CONTINUE
    3883 C
    3884       IF (.NOT.LEVOIGT) THEN
    3885         DO 231 JL = 1, KDLON
    3886         ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
    3887  231    CONTINUE
    3888         DO 233 JK = KLIM+1 , KFLEV+1
    3889         DO 232 JL = 1, KDLON
    3890         ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
    3891         PFLUX(JL,1,JK) = ZFN10(JL)
    3892         PFLUX(JL,2,JK) = 0.0
    3893  232    CONTINUE
    3894  233    CONTINUE
    3895       ENDIF
    3896 C
    3897       RETURN
    3898       END
    3899       SUBROUTINE LWB(PDT0,PTAVE,PTL
    3900      S  , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
    3901      S  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
    3902       USE dimphy
    3903       IMPLICIT none
    3904 cym#include "dimensions.h"
    3905 cym#include "dimphy.h"
    3906 cym#include "raddim.h"
    3907 #include "raddimlw.h"
    3908 C
    3909 C-----------------------------------------------------------------------
    3910 C     PURPOSE.
    3911 C     --------
    3912 C           COMPUTES PLANCK FUNCTIONS
    3913 C
    3914 C        EXPLICIT ARGUMENTS :
    3915 C        --------------------
    3916 C     ==== INPUTS ===
    3917 C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
    3918 C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
    3919 C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
    3920 C     ==== OUTPUTS ===
    3921 C PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
    3922 C PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
    3923 C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
    3924 C PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
    3925 C PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
    3926 C PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
    3927 C PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
    3928 C PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
    3929 C PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
    3930 C PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
    3931 C
    3932 C        IMPLICIT ARGUMENTS :   NONE
    3933 C        --------------------
    3934 C
    3935 C     METHOD.
    3936 C     -------
    3937 C
    3938 C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
    3939 C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
    3940 C
    3941 C     REFERENCE.
    3942 C     ----------
    3943 C
    3944 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    3945 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
    3946 C
    3947 C     AUTHOR.
    3948 C     -------
    3949 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    3950 C
    3951 C     MODIFICATIONS.
    3952 C     --------------
    3953 C        ORIGINAL : 89-07-14
    3954 C
    3955 C-----------------------------------------------------------------------
    3956 C
    3957 C ARGUMENTS:
    3958 C
    3959       REAL*8 PDT0(KDLON)
    3960       REAL*8 PTAVE(KDLON,KFLEV)
    3961       REAL*8 PTL(KDLON,KFLEV+1)
    3962 C
    3963       REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
    3964       REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
    3965       REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
    3966       REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
    3967       REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
    3968       REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
    3969       REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
    3970       REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
    3971       REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
    3972       REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
    3973       REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
    3974       REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
    3975 C
    3976 C-------------------------------------------------------------------------
    3977 C*  LOCAL VARIABLES:
    3978       INTEGER INDB(KDLON),INDS(KDLON)
    3979       REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
    3980       REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
    3981 c
    3982       INTEGER jk, jl, ic, jnu, jf, jg
    3983       INTEGER jk1, jk2
    3984       INTEGER k, j, ixtox, indto, ixtx, indt
    3985       INTEGER indsu, indtp
    3986       REAL*8 zdsto1, zdstox, zdst1, zdstx
    3987 c
    3988 C* Quelques parametres:
    3989       REAL*8 TSTAND
    3990       PARAMETER (TSTAND=250.0)
    3991       REAL*8 TSTP
    3992       PARAMETER (TSTP=12.5)
    3993       INTEGER MXIXT
    3994       PARAMETER (MXIXT=10)
    3995 C
    3996 C* Used Data Block:
    3997       REAL*8 TINTP(11)
    3998       SAVE TINTP
    3999 c$OMP THREADPRIVATE(TINTP)
    4000       REAL*8 GA(11,16,3), GB(11,16,3)
    4001       SAVE GA, GB
    4002 c$OMP THREADPRIVATE(GA, GB)
    4003       REAL*8 XP(6,6)
    4004       SAVE XP
    4005 c$OMP THREADPRIVATE(XP)
    4006 c
    4007       DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
    4008      S             262.5, 275., 287.5, 300., 312.5 /
    4009 C-----------------------------------------------------------------------
    4010 C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
    4011 C
    4012 C
    4013 C
    4014 C
    4015 C-- R.D. -- G = - 0.2 SLA
    4016 C
    4017 C
    4018 C----- INTERVAL = 1 ----- T =  187.5
    4019 C
    4020 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4021       DATA (GA( 1, 1,IC),IC=1,3) /
    4022      S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
    4023       DATA (GB( 1, 1,IC),IC=1,3) /
    4024      S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
    4025       DATA (GA( 1, 2,IC),IC=1,3) /
    4026      S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
    4027       DATA (GB( 1, 2,IC),IC=1,3) /
    4028      S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
    4029 C
    4030 C----- INTERVAL = 1 ----- T =  200.0
    4031 C
    4032 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4033       DATA (GA( 2, 1,IC),IC=1,3) /
    4034      S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
    4035       DATA (GB( 2, 1,IC),IC=1,3) /
    4036      S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
    4037       DATA (GA( 2, 2,IC),IC=1,3) /
    4038      S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
    4039       DATA (GB( 2, 2,IC),IC=1,3) /
    4040      S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
    4041 C
    4042 C----- INTERVAL = 1 ----- T =  212.5
    4043 C
    4044 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4045       DATA (GA( 3, 1,IC),IC=1,3) /
    4046      S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
    4047       DATA (GB( 3, 1,IC),IC=1,3) /
    4048      S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
    4049       DATA (GA( 3, 2,IC),IC=1,3) /
    4050      S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
    4051       DATA (GB( 3, 2,IC),IC=1,3) /
    4052      S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
    4053 C
    4054 C----- INTERVAL = 1 ----- T =  225.0
    4055 C
    4056 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4057       DATA (GA( 4, 1,IC),IC=1,3) /
    4058      S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
    4059       DATA (GB( 4, 1,IC),IC=1,3) /
    4060      S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
    4061       DATA (GA( 4, 2,IC),IC=1,3) /
    4062      S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
    4063       DATA (GB( 4, 2,IC),IC=1,3) /
    4064      S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
    4065 C
    4066 C----- INTERVAL = 1 ----- T =  237.5
    4067 C
    4068 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4069       DATA (GA( 5, 1,IC),IC=1,3) /
    4070      S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
    4071       DATA (GB( 5, 1,IC),IC=1,3) /
    4072      S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
    4073       DATA (GA( 5, 2,IC),IC=1,3) /
    4074      S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
    4075       DATA (GB( 5, 2,IC),IC=1,3) /
    4076      S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
    4077 C
    4078 C----- INTERVAL = 1 ----- T =  250.0
    4079 C
    4080 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4081       DATA (GA( 6, 1,IC),IC=1,3) /
    4082      S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
    4083       DATA (GB( 6, 1,IC),IC=1,3) /
    4084      S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
    4085       DATA (GA( 6, 2,IC),IC=1,3) /
    4086      S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
    4087       DATA (GB( 6, 2,IC),IC=1,3) /
    4088      S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
    4089 C
    4090 C----- INTERVAL = 1 ----- T =  262.5
    4091 C
    4092 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4093       DATA (GA( 7, 1,IC),IC=1,3) /
    4094      S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
    4095       DATA (GB( 7, 1,IC),IC=1,3) /
    4096      S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
    4097       DATA (GA( 7, 2,IC),IC=1,3) /
    4098      S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
    4099       DATA (GB( 7, 2,IC),IC=1,3) /
    4100      S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
    4101 C
    4102 C----- INTERVAL = 1 ----- T =  275.0
    4103 C
    4104 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4105       DATA (GA( 8, 1,IC),IC=1,3) /
    4106      S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
    4107       DATA (GB( 8, 1,IC),IC=1,3) /
    4108      S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
    4109       DATA (GA( 8, 2,IC),IC=1,3) /
    4110      S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
    4111       DATA (GB( 8, 2,IC),IC=1,3) /
    4112      S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
    4113 C
    4114 C----- INTERVAL = 1 ----- T =  287.5
    4115 C
    4116 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4117       DATA (GA( 9, 1,IC),IC=1,3) /
    4118      S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
    4119       DATA (GB( 9, 1,IC),IC=1,3) /
    4120      S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
    4121       DATA (GA( 9, 2,IC),IC=1,3) /
    4122      S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
    4123       DATA (GB( 9, 2,IC),IC=1,3) /
    4124      S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
    4125 C
    4126 C----- INTERVAL = 1 ----- T =  300.0
    4127 C
    4128 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4129       DATA (GA(10, 1,IC),IC=1,3) /
    4130      S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
    4131       DATA (GB(10, 1,IC),IC=1,3) /
    4132      S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
    4133       DATA (GA(10, 2,IC),IC=1,3) /
    4134      S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
    4135       DATA (GB(10, 2,IC),IC=1,3) /
    4136      S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
    4137 C
    4138 C----- INTERVAL = 1 ----- T =  312.5
    4139 C
    4140 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    4141       DATA (GA(11, 1,IC),IC=1,3) /
    4142      S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
    4143       DATA (GB(11, 1,IC),IC=1,3) /
    4144      S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
    4145       DATA (GA(11, 2,IC),IC=1,3) /
    4146      S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
    4147       DATA (GB(11, 2,IC),IC=1,3) /
    4148      S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
    4149 C
    4150 C
    4151 C
    4152 C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
    4153 C
    4154 C
    4155 C
    4156 C
    4157 C--- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
    4158 C
    4159 C
    4160 C----- INTERVAL = 2 ----- T =  187.5
    4161 C
    4162 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4163       DATA (GA( 1, 3,IC),IC=1,3) /
    4164      S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
    4165       DATA (GB( 1, 3,IC),IC=1,3) /
    4166      S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
    4167       DATA (GA( 1, 4,IC),IC=1,3) /
    4168      S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
    4169       DATA (GB( 1, 4,IC),IC=1,3) /
    4170      S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
    4171 C
    4172 C----- INTERVAL = 2 ----- T =  200.0
    4173 C
    4174 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4175       DATA (GA( 2, 3,IC),IC=1,3) /
    4176      S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
    4177       DATA (GB( 2, 3,IC),IC=1,3) /
    4178      S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
    4179       DATA (GA( 2, 4,IC),IC=1,3) /
    4180      S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
    4181       DATA (GB( 2, 4,IC),IC=1,3) /
    4182      S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
    4183 C
    4184 C----- INTERVAL = 2 ----- T =  212.5
    4185 C
    4186 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4187       DATA (GA( 3, 3,IC),IC=1,3) /
    4188      S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
    4189       DATA (GB( 3, 3,IC),IC=1,3) /
    4190      S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
    4191       DATA (GA( 3, 4,IC),IC=1,3) /
    4192      S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
    4193       DATA (GB( 3, 4,IC),IC=1,3) /
    4194      S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
    4195 C
    4196 C----- INTERVAL = 2 ----- T =  225.0
    4197 C
    4198 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4199       DATA (GA( 4, 3,IC),IC=1,3) /
    4200      S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
    4201       DATA (GB( 4, 3,IC),IC=1,3) /
    4202      S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
    4203       DATA (GA( 4, 4,IC),IC=1,3) /
    4204      S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
    4205       DATA (GB( 4, 4,IC),IC=1,3) /
    4206      S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
    4207 C
    4208 C----- INTERVAL = 2 ----- T =  237.5
    4209 C
    4210 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4211       DATA (GA( 5, 3,IC),IC=1,3) /
    4212      S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
    4213       DATA (GB( 5, 3,IC),IC=1,3) /
    4214      S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
    4215       DATA (GA( 5, 4,IC),IC=1,3) /
    4216      S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
    4217       DATA (GB( 5, 4,IC),IC=1,3) /
    4218      S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
    4219 C
    4220 C----- INTERVAL = 2 ----- T =  250.0
    4221 C
    4222 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4223       DATA (GA( 6, 3,IC),IC=1,3) /
    4224      S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
    4225       DATA (GB( 6, 3,IC),IC=1,3) /
    4226      S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
    4227       DATA (GA( 6, 4,IC),IC=1,3) /
    4228      S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
    4229       DATA (GB( 6, 4,IC),IC=1,3) /
    4230      S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
    4231 C
    4232 C----- INTERVAL = 2 ----- T =  262.5
    4233 C
    4234 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4235       DATA (GA( 7, 3,IC),IC=1,3) /
    4236      S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
    4237       DATA (GB( 7, 3,IC),IC=1,3) /
    4238      S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
    4239       DATA (GA( 7, 4,IC),IC=1,3) /
    4240      S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
    4241       DATA (GB( 7, 4,IC),IC=1,3) /
    4242      S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
    4243 C
    4244 C----- INTERVAL = 2 ----- T =  275.0
    4245 C
    4246 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4247       DATA (GA( 8, 3,IC),IC=1,3) /
    4248      S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
    4249       DATA (GB( 8, 3,IC),IC=1,3) /
    4250      S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
    4251       DATA (GA( 8, 4,IC),IC=1,3) /
    4252      S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
    4253       DATA (GB( 8, 4,IC),IC=1,3) /
    4254      S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
    4255 C
    4256 C----- INTERVAL = 2 ----- T =  287.5
    4257 C
    4258 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4259       DATA (GA( 9, 3,IC),IC=1,3) /
    4260      S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
    4261       DATA (GB( 9, 3,IC),IC=1,3) /
    4262      S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
    4263       DATA (GA( 9, 4,IC),IC=1,3) /
    4264      S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
    4265       DATA (GB( 9, 4,IC),IC=1,3) /
    4266      S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
    4267 C
    4268 C----- INTERVAL = 2 ----- T =  300.0
    4269 C
    4270 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4271       DATA (GA(10, 3,IC),IC=1,3) /
    4272      S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
    4273       DATA (GB(10, 3,IC),IC=1,3) /
    4274      S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
    4275       DATA (GA(10, 4,IC),IC=1,3) /
    4276      S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
    4277       DATA (GB(10, 4,IC),IC=1,3) /
    4278      S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
    4279 C
    4280 C----- INTERVAL = 2 ----- T =  312.5
    4281 C
    4282 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4283       DATA (GA(11, 3,IC),IC=1,3) /
    4284      S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
    4285       DATA (GB(11, 3,IC),IC=1,3) /
    4286      S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
    4287       DATA (GA(11, 4,IC),IC=1,3) /
    4288      S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
    4289       DATA (GB(11, 4,IC),IC=1,3) /
    4290      S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
    4291 C
    4292 C
    4293 C
    4294 C
    4295 C
    4296 C
    4297 C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
    4298 C
    4299 C
    4300 C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
    4301 C
    4302 C
    4303 C
    4304 C--- G = 3.875E-03 ---------------
    4305 C
    4306 C----- INTERVAL = 3 ----- T =  187.5
    4307 C
    4308 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4309       DATA (GA( 1, 7,IC),IC=1,3) /
    4310      S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
    4311       DATA (GB( 1, 7,IC),IC=1,3) /
    4312      S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
    4313       DATA (GA( 1, 8,IC),IC=1,3) /
    4314      S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
    4315       DATA (GB( 1, 8,IC),IC=1,3) /
    4316      S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
    4317 C
    4318 C----- INTERVAL = 3 ----- T =  200.0
    4319 C
    4320 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4321       DATA (GA( 2, 7,IC),IC=1,3) /
    4322      S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
    4323       DATA (GB( 2, 7,IC),IC=1,3) /
    4324      S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
    4325       DATA (GA( 2, 8,IC),IC=1,3) /
    4326      S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
    4327       DATA (GB( 2, 8,IC),IC=1,3) /
    4328      S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
    4329 C
    4330 C----- INTERVAL = 3 ----- T =  212.5
    4331 C
    4332 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4333       DATA (GA( 3, 7,IC),IC=1,3) /
    4334      S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
    4335       DATA (GB( 3, 7,IC),IC=1,3) /
    4336      S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
    4337       DATA (GA( 3, 8,IC),IC=1,3) /
    4338      S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
    4339       DATA (GB( 3, 8,IC),IC=1,3) /
    4340      S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
    4341 C
    4342 C----- INTERVAL = 3 ----- T =  225.0
    4343 C
    4344 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4345       DATA (GA( 4, 7,IC),IC=1,3) /
    4346      S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
    4347       DATA (GB( 4, 7,IC),IC=1,3) /
    4348      S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
    4349       DATA (GA( 4, 8,IC),IC=1,3) /
    4350      S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
    4351       DATA (GB( 4, 8,IC),IC=1,3) /
    4352      S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
    4353 C
    4354 C----- INTERVAL = 3 ----- T =  237.5
    4355 C
    4356 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4357       DATA (GA( 5, 7,IC),IC=1,3) /
    4358      S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
    4359       DATA (GB( 5, 7,IC),IC=1,3) /
    4360      S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
    4361       DATA (GA( 5, 8,IC),IC=1,3) /
    4362      S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
    4363       DATA (GB( 5, 8,IC),IC=1,3) /
    4364      S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
    4365 C
    4366 C----- INTERVAL = 3 ----- T =  250.0
    4367 C
    4368 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4369       DATA (GA( 6, 7,IC),IC=1,3) /
    4370      S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
    4371       DATA (GB( 6, 7,IC),IC=1,3) /
    4372      S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
    4373       DATA (GA( 6, 8,IC),IC=1,3) /
    4374      S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
    4375       DATA (GB( 6, 8,IC),IC=1,3) /
    4376      S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
    4377 C
    4378 C----- INTERVAL = 3 ----- T =  262.5
    4379 C
    4380 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4381       DATA (GA( 7, 7,IC),IC=1,3) /
    4382      S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
    4383       DATA (GB( 7, 7,IC),IC=1,3) /
    4384      S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
    4385       DATA (GA( 7, 8,IC),IC=1,3) /
    4386      S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
    4387       DATA (GB( 7, 8,IC),IC=1,3) /
    4388      S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
    4389 C
    4390 C----- INTERVAL = 3 ----- T =  275.0
    4391 C
    4392 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4393       DATA (GA( 8, 7,IC),IC=1,3) /
    4394      S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
    4395       DATA (GB( 8, 7,IC),IC=1,3) /
    4396      S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
    4397       DATA (GA( 8, 8,IC),IC=1,3) /
    4398      S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
    4399       DATA (GB( 8, 8,IC),IC=1,3) /
    4400      S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
    4401 C
    4402 C----- INTERVAL = 3 ----- T =  287.5
    4403 C
    4404 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4405       DATA (GA( 9, 7,IC),IC=1,3) /
    4406      S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
    4407       DATA (GB( 9, 7,IC),IC=1,3) /
    4408      S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
    4409       DATA (GA( 9, 8,IC),IC=1,3) /
    4410      S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
    4411       DATA (GB( 9, 8,IC),IC=1,3) /
    4412      S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
    4413 C
    4414 C----- INTERVAL = 3 ----- T =  300.0
    4415 C
    4416 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4417       DATA (GA(10, 7,IC),IC=1,3) /
    4418      S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
    4419       DATA (GB(10, 7,IC),IC=1,3) /
    4420      S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
    4421       DATA (GA(10, 8,IC),IC=1,3) /
    4422      S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
    4423       DATA (GB(10, 8,IC),IC=1,3) /
    4424      S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
    4425 C
    4426 C----- INTERVAL = 3 ----- T =  312.5
    4427 C
    4428 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4429       DATA (GA(11, 7,IC),IC=1,3) /
    4430      S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
    4431       DATA (GB(11, 7,IC),IC=1,3) /
    4432      S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
    4433       DATA (GA(11, 8,IC),IC=1,3) /
    4434      S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
    4435       DATA (GB(11, 8,IC),IC=1,3) /
    4436      S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
    4437 C
    4438 C
    4439 C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
    4440 C
    4441 C-- G = 3.6E-03
    4442 C
    4443 C----- INTERVAL = 4 ----- T =  187.5
    4444 C
    4445 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4446       DATA (GA( 1, 9,IC),IC=1,3) /
    4447      S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
    4448       DATA (GB( 1, 9,IC),IC=1,3) /
    4449      S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
    4450       DATA (GA( 1,10,IC),IC=1,3) /
    4451      S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
    4452       DATA (GB( 1,10,IC),IC=1,3) /
    4453      S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
    4454 C
    4455 C----- INTERVAL = 4 ----- T =  200.0
    4456 C
    4457 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4458       DATA (GA( 2, 9,IC),IC=1,3) /
    4459      S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
    4460       DATA (GB( 2, 9,IC),IC=1,3) /
    4461      S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
    4462       DATA (GA( 2,10,IC),IC=1,3) /
    4463      S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
    4464       DATA (GB( 2,10,IC),IC=1,3) /
    4465      S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
    4466 C
    4467 C----- INTERVAL = 4 ----- T =  212.5
    4468 C
    4469 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4470       DATA (GA( 3, 9,IC),IC=1,3) /
    4471      S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
    4472       DATA (GB( 3, 9,IC),IC=1,3) /
    4473      S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
    4474       DATA (GA( 3,10,IC),IC=1,3) /
    4475      S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
    4476       DATA (GB( 3,10,IC),IC=1,3) /
    4477      S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
    4478 C
    4479 C----- INTERVAL = 4 ----- T =  225.0
    4480 C
    4481 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4482       DATA (GA( 4, 9,IC),IC=1,3) /
    4483      S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
    4484       DATA (GB( 4, 9,IC),IC=1,3) /
    4485      S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
    4486       DATA (GA( 4,10,IC),IC=1,3) /
    4487      S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
    4488       DATA (GB( 4,10,IC),IC=1,3) /
    4489      S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
    4490 C
    4491 C----- INTERVAL = 4 ----- T =  237.5
    4492 C
    4493 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4494       DATA (GA( 5, 9,IC),IC=1,3) /
    4495      S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
    4496       DATA (GB( 5, 9,IC),IC=1,3) /
    4497      S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
    4498       DATA (GA( 5,10,IC),IC=1,3) /
    4499      S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
    4500       DATA (GB( 5,10,IC),IC=1,3) /
    4501      S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
    4502 C
    4503 C----- INTERVAL = 4 ----- T =  250.0
    4504 C
    4505 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4506       DATA (GA( 6, 9,IC),IC=1,3) /
    4507      S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
    4508       DATA (GB( 6, 9,IC),IC=1,3) /
    4509      S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
    4510       DATA (GA( 6,10,IC),IC=1,3) /
    4511      S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
    4512       DATA (GB( 6,10,IC),IC=1,3) /
    4513      S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
    4514 C
    4515 C----- INTERVAL = 4 ----- T =  262.5
    4516 C
    4517 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4518       DATA (GA( 7, 9,IC),IC=1,3) /
    4519      S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
    4520       DATA (GB( 7, 9,IC),IC=1,3) /
    4521      S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
    4522       DATA (GA( 7,10,IC),IC=1,3) /
    4523      S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
    4524       DATA (GB( 7,10,IC),IC=1,3) /
    4525      S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
    4526 C
    4527 C----- INTERVAL = 4 ----- T =  275.0
    4528 C
    4529 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4530       DATA (GA( 8, 9,IC),IC=1,3) /
    4531      S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
    4532       DATA (GB( 8, 9,IC),IC=1,3) /
    4533      S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
    4534       DATA (GA( 8,10,IC),IC=1,3) /
    4535      S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
    4536       DATA (GB( 8,10,IC),IC=1,3) /
    4537      S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
    4538 C
    4539 C----- INTERVAL = 4 ----- T =  287.5
    4540 C
    4541 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4542       DATA (GA( 9, 9,IC),IC=1,3) /
    4543      S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
    4544       DATA (GB( 9, 9,IC),IC=1,3) /
    4545      S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
    4546       DATA (GA( 9,10,IC),IC=1,3) /
    4547      S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
    4548       DATA (GB( 9,10,IC),IC=1,3) /
    4549      S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
    4550 C
    4551 C----- INTERVAL = 4 ----- T =  300.0
    4552 C
    4553 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4554       DATA (GA(10, 9,IC),IC=1,3) /
    4555      S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
    4556       DATA (GB(10, 9,IC),IC=1,3) /
    4557      S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
    4558       DATA (GA(10,10,IC),IC=1,3) /
    4559      S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
    4560       DATA (GB(10,10,IC),IC=1,3) /
    4561      S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
    4562 C
    4563 C----- INTERVAL = 4 ----- T =  312.5
    4564 C
    4565 C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
    4566       DATA (GA(11, 9,IC),IC=1,3) /
    4567      S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
    4568       DATA (GB(11, 9,IC),IC=1,3) /
    4569      S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
    4570       DATA (GA(11,10,IC),IC=1,3) /
    4571      S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
    4572       DATA (GB(11,10,IC),IC=1,3) /
    4573      S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
    4574 C
    4575 C
    4576 C
    4577 C-- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
    4578 C
    4579 C-- WATER VAPOR --- 350 - 500 CM-1
    4580 C
    4581 C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
    4582 C
    4583 C----- INTERVAL = 5 ----- T =  187.5
    4584 C
    4585 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4586       DATA (GA( 1, 5,IC),IC=1,3) /
    4587      S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
    4588       DATA (GB( 1, 5,IC),IC=1,3) /
    4589      S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
    4590       DATA (GA( 1, 6,IC),IC=1,3) /
    4591      S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
    4592       DATA (GB( 1, 6,IC),IC=1,3) /
    4593      S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
    4594 C
    4595 C----- INTERVAL = 5 ----- T =  200.0
    4596 C
    4597 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4598       DATA (GA( 2, 5,IC),IC=1,3) /
    4599      S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
    4600       DATA (GB( 2, 5,IC),IC=1,3) /
    4601      S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
    4602       DATA (GA( 2, 6,IC),IC=1,3) /
    4603      S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
    4604       DATA (GB( 2, 6,IC),IC=1,3) /
    4605      S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
    4606 C
    4607 C----- INTERVAL = 5 ----- T =  212.5
    4608 C
    4609 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4610       DATA (GA( 3, 5,IC),IC=1,3) /
    4611      S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
    4612       DATA (GB( 3, 5,IC),IC=1,3) /
    4613      S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
    4614       DATA (GA( 3, 6,IC),IC=1,3) /
    4615      S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
    4616       DATA (GB( 3, 6,IC),IC=1,3) /
    4617      S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
    4618 C
    4619 C----- INTERVAL = 5 ----- T =  225.0
    4620 C
    4621 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4622       DATA (GA( 4, 5,IC),IC=1,3) /
    4623      S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
    4624       DATA (GB( 4, 5,IC),IC=1,3) /
    4625      S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
    4626       DATA (GA( 4, 6,IC),IC=1,3) /
    4627      S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
    4628       DATA (GB( 4, 6,IC),IC=1,3) /
    4629      S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
    4630 C
    4631 C----- INTERVAL = 5 ----- T =  237.5
    4632 C
    4633 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4634       DATA (GA( 5, 5,IC),IC=1,3) /
    4635      S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
    4636       DATA (GB( 5, 5,IC),IC=1,3) /
    4637      S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
    4638       DATA (GA( 5, 6,IC),IC=1,3) /
    4639      S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
    4640       DATA (GB( 5, 6,IC),IC=1,3) /
    4641      S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
    4642 C
    4643 C----- INTERVAL = 5 ----- T =  250.0
    4644 C
    4645 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4646       DATA (GA( 6, 5,IC),IC=1,3) /
    4647      S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
    4648       DATA (GB( 6, 5,IC),IC=1,3) /
    4649      S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
    4650       DATA (GA( 6, 6,IC),IC=1,3) /
    4651      S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
    4652       DATA (GB( 6, 6,IC),IC=1,3) /
    4653      S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
    4654 C
    4655 C----- INTERVAL = 5 ----- T =  262.5
    4656 C
    4657 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4658       DATA (GA( 7, 5,IC),IC=1,3) /
    4659      S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
    4660       DATA (GB( 7, 5,IC),IC=1,3) /
    4661      S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
    4662       DATA (GA( 7, 6,IC),IC=1,3) /
    4663      S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
    4664       DATA (GB( 7, 6,IC),IC=1,3) /
    4665      S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
    4666 C
    4667 C----- INTERVAL = 5 ----- T =  275.0
    4668 C
    4669 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4670       DATA (GA( 8, 5,IC),IC=1,3) /
    4671      S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
    4672       DATA (GB( 8, 5,IC),IC=1,3) /
    4673      S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
    4674       DATA (GA( 8, 6,IC),IC=1,3) /
    4675      S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
    4676       DATA (GB( 8, 6,IC),IC=1,3) /
    4677      S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
    4678 C
    4679 C----- INTERVAL = 5 ----- T =  287.5
    4680 C
    4681 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4682       DATA (GA( 9, 5,IC),IC=1,3) /
    4683      S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
    4684       DATA (GB( 9, 5,IC),IC=1,3) /
    4685      S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
    4686       DATA (GA( 9, 6,IC),IC=1,3) /
    4687      S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
    4688       DATA (GB( 9, 6,IC),IC=1,3) /
    4689      S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
    4690 C
    4691 C----- INTERVAL = 5 ----- T =  300.0
    4692 C
    4693 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4694       DATA (GA(10, 5,IC),IC=1,3) /
    4695      S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
    4696       DATA (GB(10, 5,IC),IC=1,3) /
    4697      S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
    4698       DATA (GA(10, 6,IC),IC=1,3) /
    4699      S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
    4700       DATA (GB(10, 6,IC),IC=1,3) /
    4701      S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
    4702 C
    4703 C----- INTERVAL = 5 ----- T =  312.5
    4704 C
    4705 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4706       DATA (GA(11, 5,IC),IC=1,3) /
    4707      S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
    4708       DATA (GB(11, 5,IC),IC=1,3) /
    4709      S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
    4710       DATA (GA(11, 6,IC),IC=1,3) /
    4711      S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
    4712       DATA (GB(11, 6,IC),IC=1,3) /
    4713      S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
    4714 C
    4715 C
    4716 C
    4717 C
    4718 C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
    4719 C--- G = 0.0
    4720 C
    4721 C
    4722 C----- INTERVAL = 6 ----- T =  187.5
    4723 C
    4724 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4725       DATA (GA( 1,11,IC),IC=1,3) /
    4726      S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
    4727       DATA (GB( 1,11,IC),IC=1,3) /
    4728      S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
    4729       DATA (GA( 1,12,IC),IC=1,3) /
    4730      S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
    4731       DATA (GB( 1,12,IC),IC=1,3) /
    4732      S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
    4733 C
    4734 C----- INTERVAL = 6 ----- T =  200.0
    4735 C
    4736 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4737       DATA (GA( 2,11,IC),IC=1,3) /
    4738      S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
    4739       DATA (GB( 2,11,IC),IC=1,3) /
    4740      S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
    4741       DATA (GA( 2,12,IC),IC=1,3) /
    4742      S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
    4743       DATA (GB( 2,12,IC),IC=1,3) /
    4744      S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
    4745 C
    4746 C----- INTERVAL = 6 ----- T =  212.5
    4747 C
    4748 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4749       DATA (GA( 3,11,IC),IC=1,3) /
    4750      S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
    4751       DATA (GB( 3,11,IC),IC=1,3) /
    4752      S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
    4753       DATA (GA( 3,12,IC),IC=1,3) /
    4754      S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
    4755       DATA (GB( 3,12,IC),IC=1,3) /
    4756      S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
    4757 C
    4758 C----- INTERVAL = 6 ----- T =  225.0
    4759 C
    4760 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4761       DATA (GA( 4,11,IC),IC=1,3) /
    4762      S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
    4763       DATA (GB( 4,11,IC),IC=1,3) /
    4764      S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
    4765       DATA (GA( 4,12,IC),IC=1,3) /
    4766      S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
    4767       DATA (GB( 4,12,IC),IC=1,3) /
    4768      S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
    4769 C
    4770 C----- INTERVAL = 6 ----- T =  237.5
    4771 C
    4772 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4773       DATA (GA( 5,11,IC),IC=1,3) /
    4774      S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
    4775       DATA (GB( 5,11,IC),IC=1,3) /
    4776      S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
    4777       DATA (GA( 5,12,IC),IC=1,3) /
    4778      S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
    4779       DATA (GB( 5,12,IC),IC=1,3) /
    4780      S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
    4781 C
    4782 C----- INTERVAL = 6 ----- T =  250.0
    4783 C
    4784 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4785       DATA (GA( 6,11,IC),IC=1,3) /
    4786      S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
    4787       DATA (GB( 6,11,IC),IC=1,3) /
    4788      S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
    4789       DATA (GA( 6,12,IC),IC=1,3) /
    4790      S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
    4791       DATA (GB( 6,12,IC),IC=1,3) /
    4792      S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
    4793 C
    4794 C----- INTERVAL = 6 ----- T =  262.5
    4795 C
    4796 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4797       DATA (GA( 7,11,IC),IC=1,3) /
    4798      S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
    4799       DATA (GB( 7,11,IC),IC=1,3) /
    4800      S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
    4801       DATA (GA( 7,12,IC),IC=1,3) /
    4802      S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
    4803       DATA (GB( 7,12,IC),IC=1,3) /
    4804      S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
    4805 C
    4806 C----- INTERVAL = 6 ----- T =  275.0
    4807 C
    4808 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4809       DATA (GA( 8,11,IC),IC=1,3) /
    4810      S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
    4811       DATA (GB( 8,11,IC),IC=1,3) /
    4812      S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
    4813       DATA (GA( 8,12,IC),IC=1,3) /
    4814      S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
    4815       DATA (GB( 8,12,IC),IC=1,3) /
    4816      S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
    4817 C
    4818 C----- INTERVAL = 6 ----- T =  287.5
    4819 C
    4820 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4821       DATA (GA( 9,11,IC),IC=1,3) /
    4822      S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
    4823       DATA (GB( 9,11,IC),IC=1,3) /
    4824      S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
    4825       DATA (GA( 9,12,IC),IC=1,3) /
    4826      S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
    4827       DATA (GB( 9,12,IC),IC=1,3) /
    4828      S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
    4829 C
    4830 C----- INTERVAL = 6 ----- T =  300.0
    4831 C
    4832 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4833       DATA (GA(10,11,IC),IC=1,3) /
    4834      S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
    4835       DATA (GB(10,11,IC),IC=1,3) /
    4836      S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
    4837       DATA (GA(10,12,IC),IC=1,3) /
    4838      S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
    4839       DATA (GB(10,12,IC),IC=1,3) /
    4840      S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
    4841 C
    4842 C----- INTERVAL = 6 ----- T =  312.5
    4843 C
    4844 C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
    4845       DATA (GA(11,11,IC),IC=1,3) /
    4846      S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
    4847       DATA (GB(11,11,IC),IC=1,3) /
    4848      S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
    4849       DATA (GA(11,12,IC),IC=1,3) /
    4850      S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
    4851       DATA (GB(11,12,IC),IC=1,3) /
    4852      S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
    4853 C
    4854 C
    4855 C
    4856 C
    4857 C
    4858 C-- END WATER VAPOR
    4859 C
    4860 C
    4861 C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
    4862 C
    4863 C
    4864 C
    4865 C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
    4866 C
    4867 C----- INTERVAL = 2 ----- T =  187.5
    4868 C
    4869 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4870       DATA (GA( 1,13,IC),IC=1,3) /
    4871      S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
    4872       DATA (GB( 1,13,IC),IC=1,3) /
    4873      S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
    4874       DATA (GA( 1,14,IC),IC=1,3) /
    4875      S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
    4876       DATA (GB( 1,14,IC),IC=1,3) /
    4877      S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
    4878 C
    4879 C----- INTERVAL = 2 ----- T =  200.0
    4880 C
    4881 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4882       DATA (GA( 2,13,IC),IC=1,3) /
    4883      S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
    4884       DATA (GB( 2,13,IC),IC=1,3) /
    4885      S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
    4886       DATA (GA( 2,14,IC),IC=1,3) /
    4887      S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
    4888       DATA (GB( 2,14,IC),IC=1,3) /
    4889      S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
    4890 C
    4891 C----- INTERVAL = 2 ----- T =  212.5
    4892 C
    4893 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4894       DATA (GA( 3,13,IC),IC=1,3) /
    4895      S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
    4896       DATA (GB( 3,13,IC),IC=1,3) /
    4897      S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
    4898       DATA (GA( 3,14,IC),IC=1,3) /
    4899      S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
    4900       DATA (GB( 3,14,IC),IC=1,3) /
    4901      S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
    4902 C
    4903 C----- INTERVAL = 2 ----- T =  225.0
    4904 C
    4905 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4906       DATA (GA( 4,13,IC),IC=1,3) /
    4907      S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
    4908       DATA (GB( 4,13,IC),IC=1,3) /
    4909      S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
    4910       DATA (GA( 4,14,IC),IC=1,3) /
    4911      S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
    4912       DATA (GB( 4,14,IC),IC=1,3) /
    4913      S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
    4914 C
    4915 C----- INTERVAL = 2 ----- T =  237.5
    4916 C
    4917 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4918       DATA (GA( 5,13,IC),IC=1,3) /
    4919      S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
    4920       DATA (GB( 5,13,IC),IC=1,3) /
    4921      S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
    4922       DATA (GA( 5,14,IC),IC=1,3) /
    4923      S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
    4924       DATA (GB( 5,14,IC),IC=1,3) /
    4925      S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
    4926 C
    4927 C----- INTERVAL = 2 ----- T =  250.0
    4928 C
    4929 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4930       DATA (GA( 6,13,IC),IC=1,3) /
    4931      S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
    4932       DATA (GB( 6,13,IC),IC=1,3) /
    4933      S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
    4934       DATA (GA( 6,14,IC),IC=1,3) /
    4935      S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
    4936       DATA (GB( 6,14,IC),IC=1,3) /
    4937      S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
    4938 C
    4939 C----- INTERVAL = 2 ----- T =  262.5
    4940 C
    4941 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4942       DATA (GA( 7,13,IC),IC=1,3) /
    4943      S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
    4944       DATA (GB( 7,13,IC),IC=1,3) /
    4945      S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
    4946       DATA (GA( 7,14,IC),IC=1,3) /
    4947      S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
    4948       DATA (GB( 7,14,IC),IC=1,3) /
    4949      S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
    4950 C
    4951 C----- INTERVAL = 2 ----- T =  275.0
    4952 C
    4953 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4954       DATA (GA( 8,13,IC),IC=1,3) /
    4955      S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
    4956       DATA (GB( 8,13,IC),IC=1,3) /
    4957      S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
    4958       DATA (GA( 8,14,IC),IC=1,3) /
    4959      S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
    4960       DATA (GB( 8,14,IC),IC=1,3) /
    4961      S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
    4962 C
    4963 C----- INTERVAL = 2 ----- T =  287.5
    4964 C
    4965 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4966       DATA (GA( 9,13,IC),IC=1,3) /
    4967      S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
    4968       DATA (GB( 9,13,IC),IC=1,3) /
    4969      S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
    4970       DATA (GA( 9,14,IC),IC=1,3) /
    4971      S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
    4972       DATA (GB( 9,14,IC),IC=1,3) /
    4973      S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
    4974 C
    4975 C----- INTERVAL = 2 ----- T =  300.0
    4976 C
    4977 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4978       DATA (GA(10,13,IC),IC=1,3) /
    4979      S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
    4980       DATA (GB(10,13,IC),IC=1,3) /
    4981      S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
    4982       DATA (GA(10,14,IC),IC=1,3) /
    4983      S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
    4984       DATA (GB(10,14,IC),IC=1,3) /
    4985      S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
    4986 C
    4987 C----- INTERVAL = 2 ----- T =  312.5
    4988 C
    4989 C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
    4990       DATA (GA(11,13,IC),IC=1,3) /
    4991      S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
    4992       DATA (GB(11,13,IC),IC=1,3) /
    4993      S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
    4994       DATA (GA(11,14,IC),IC=1,3) /
    4995      S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
    4996       DATA (GB(11,14,IC),IC=1,3) /
    4997      S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
    4998 C
    4999 C
    5000 C
    5001 C
    5002 C
    5003 C
    5004 C
    5005 C
    5006 C
    5007 C
    5008 C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
    5009 C
    5010 C
    5011 C-- G = 0.0
    5012 C
    5013 C
    5014 C----- INTERVAL = 4 ----- T =  187.5
    5015 C
    5016 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5017       DATA (GA( 1,15,IC),IC=1,3) /
    5018      S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
    5019       DATA (GB( 1,15,IC),IC=1,3) /
    5020      S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
    5021       DATA (GA( 1,16,IC),IC=1,3) /
    5022      S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
    5023       DATA (GB( 1,16,IC),IC=1,3) /
    5024      S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
    5025 C
    5026 C----- INTERVAL = 4 ----- T =  200.0
    5027 C
    5028 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5029       DATA (GA( 2,15,IC),IC=1,3) /
    5030      S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
    5031       DATA (GB( 2,15,IC),IC=1,3) /
    5032      S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
    5033       DATA (GA( 2,16,IC),IC=1,3) /
    5034      S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
    5035       DATA (GB( 2,16,IC),IC=1,3) /
    5036      S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
    5037 C
    5038 C----- INTERVAL = 4 ----- T =  212.5
    5039 C
    5040 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5041       DATA (GA( 3,15,IC),IC=1,3) /
    5042      S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
    5043       DATA (GB( 3,15,IC),IC=1,3) /
    5044      S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
    5045       DATA (GA( 3,16,IC),IC=1,3) /
    5046      S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
    5047       DATA (GB( 3,16,IC),IC=1,3) /
    5048      S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
    5049 C
    5050 C----- INTERVAL = 4 ----- T =  225.0
    5051 C
    5052 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5053       DATA (GA( 4,15,IC),IC=1,3) /
    5054      S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
    5055       DATA (GB( 4,15,IC),IC=1,3) /
    5056      S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
    5057       DATA (GA( 4,16,IC),IC=1,3) /
    5058      S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
    5059       DATA (GB( 4,16,IC),IC=1,3) /
    5060      S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
    5061 C
    5062 C----- INTERVAL = 4 ----- T =  237.5
    5063 C
    5064 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5065       DATA (GA( 5,15,IC),IC=1,3) /
    5066      S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
    5067       DATA (GB( 5,15,IC),IC=1,3) /
    5068      S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
    5069       DATA (GA( 5,16,IC),IC=1,3) /
    5070      S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
    5071       DATA (GB( 5,16,IC),IC=1,3) /
    5072      S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
    5073 C
    5074 C----- INTERVAL = 4 ----- T =  250.0
    5075 C
    5076 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5077       DATA (GA( 6,15,IC),IC=1,3) /
    5078      S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
    5079       DATA (GB( 6,15,IC),IC=1,3) /
    5080      S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
    5081       DATA (GA( 6,16,IC),IC=1,3) /
    5082      S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
    5083       DATA (GB( 6,16,IC),IC=1,3) /
    5084      S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
    5085 C
    5086 C----- INTERVAL = 4 ----- T =  262.5
    5087 C
    5088 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5089       DATA (GA( 7,15,IC),IC=1,3) /
    5090      S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
    5091       DATA (GB( 7,15,IC),IC=1,3) /
    5092      S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
    5093       DATA (GA( 7,16,IC),IC=1,3) /
    5094      S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
    5095       DATA (GB( 7,16,IC),IC=1,3) /
    5096      S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
    5097 C
    5098 C----- INTERVAL = 4 ----- T =  275.0
    5099 C
    5100 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5101       DATA (GA( 8,15,IC),IC=1,3) /
    5102      S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
    5103       DATA (GB( 8,15,IC),IC=1,3) /
    5104      S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
    5105       DATA (GA( 8,16,IC),IC=1,3) /
    5106      S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
    5107       DATA (GB( 8,16,IC),IC=1,3) /
    5108      S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
    5109 C
    5110 C----- INTERVAL = 4 ----- T =  287.5
    5111 C
    5112 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5113       DATA (GA( 9,15,IC),IC=1,3) /
    5114      S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
    5115       DATA (GB( 9,15,IC),IC=1,3) /
    5116      S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
    5117       DATA (GA( 9,16,IC),IC=1,3) /
    5118      S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
    5119       DATA (GB( 9,16,IC),IC=1,3) /
    5120      S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
    5121 C
    5122 C----- INTERVAL = 4 ----- T =  300.0
    5123 C
    5124 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5125       DATA (GA(10,15,IC),IC=1,3) /
    5126      S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
    5127       DATA (GB(10,15,IC),IC=1,3) /
    5128      S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
    5129       DATA (GA(10,16,IC),IC=1,3) /
    5130      S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
    5131       DATA (GB(10,16,IC),IC=1,3) /
    5132      S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
    5133 C
    5134 C----- INTERVAL = 4 ----- T =  312.5
    5135 C
    5136 C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
    5137       DATA (GA(11,15,IC),IC=1,3) /
    5138      S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
    5139       DATA (GB(11,15,IC),IC=1,3) /
    5140      S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
    5141       DATA (GA(11,16,IC),IC=1,3) /
    5142      S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
    5143       DATA (GB(11,16,IC),IC=1,3) /
    5144      S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
    5145 
    5146 C     ------------------------------------------------------------------
    5147       DATA (( XP(  J,K),J=1,6),       K=1,6) /
    5148      S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
    5149      S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
    5150      S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
    5151      S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
    5152      S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
    5153      S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
    5154      S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
    5155      S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
    5156      S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
    5157      S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
    5158      S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
    5159      S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
    5160 C
    5161 C
    5162 C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
    5163 C                  ------------------------------
    5164 C
    5165  100  CONTINUE
    5166 C
    5167       DO 102 JK = 1 , KFLEV+1
    5168       DO 101 JL = 1, KDLON
    5169       PBINT(JL,JK) = 0.
    5170  101  CONTINUE
    5171  102  CONTINUE
    5172       DO 103 JL = 1, KDLON
    5173       PBSUIN(JL) = 0.
    5174  103  CONTINUE
    5175 C
    5176       DO 141 JNU=1,Ninter
    5177 C
    5178 C
    5179 C*         1.1   LEVELS FROM SURFACE TO KFLEV
    5180 C                ----------------------------
    5181 C
    5182  110  CONTINUE
    5183 C
    5184       DO 112 JK = 1 , KFLEV
    5185       DO 111 JL = 1, KDLON
    5186       ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
    5187       ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
    5188      S       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
    5189      S       )))))
    5190       PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
    5191       PB(JL,JNU,JK)= ZRES(JL)
    5192       ZBLEV(JL,JK) = ZRES(JL)
    5193       ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
    5194       ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
    5195      S     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
    5196      S       )))))
    5197       ZBLAY(JL,JK) = ZRES2(JL)
    5198  111  CONTINUE
    5199  112  CONTINUE
    5200 C
    5201 C
    5202 C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
    5203 C                ---------------------------------
    5204 C
    5205  120  CONTINUE
    5206 C
    5207       DO 121 JL = 1, KDLON
    5208       ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
    5209       ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
    5210       ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
    5211      S    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
    5212      S       )))))
    5213       ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
    5214      S    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
    5215      S       )))))
    5216       PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
    5217       PB(JL,JNU,KFLEV+1)= ZRES(JL)
    5218       ZBLEV(JL,KFLEV+1) = ZRES(JL)
    5219       PBTOP(JL,JNU) = ZRES(JL)
    5220       PBSUR(JL,JNU) = ZRES2(JL)
    5221       PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
    5222  121  CONTINUE
    5223 C
    5224 C
    5225 C*         1.3   GRADIENTS IN SUB-LAYERS
    5226 C                -----------------------
    5227 C
    5228  130  CONTINUE
    5229 C
    5230       DO 132 JK = 1 , KFLEV
    5231       JK2 = 2 * JK
    5232       JK1 = JK2 - 1
    5233       DO 131 JL = 1, KDLON
    5234       PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
    5235       PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
    5236  131  CONTINUE
    5237  132  CONTINUE
    5238 C
    5239  141  CONTINUE
    5240 C
    5241 C*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
    5242 C                ---------------------------------------------
    5243 C
    5244  200  CONTINUE
    5245 C
    5246 C
    5247  210  CONTINUE
    5248 C
    5249       DO 211 JL=1, KDLON
    5250       ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
    5251       IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
    5252       ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
    5253       IF (ZDSTOX.LT.0.5) THEN
    5254          INDTO=IXTOX
    5255       ELSE
    5256          INDTO=IXTOX+1
    5257       END IF
    5258       INDB(JL)=INDTO
    5259       ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
    5260       IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
    5261       ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
    5262       IF (ZDSTX.LT.0.5) THEN
    5263          INDT=IXTX
    5264       ELSE
    5265          INDT=IXTX+1
    5266       END IF
    5267       INDS(JL)=INDT
    5268  211  CONTINUE
    5269 C
    5270       DO 214 JF=1,2
    5271       DO 213 JG=1, 8
    5272       DO 212 JL=1, KDLON
    5273       INDSU=INDS(JL)
    5274       PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
    5275       PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
    5276       INDTP=INDB(JL)
    5277       PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
    5278       PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
    5279  212  CONTINUE
    5280  213  CONTINUE
    5281  214  CONTINUE
    5282 C
    5283  220  CONTINUE
    5284 C
    5285       DO 225 JK=1,KFLEV
    5286       DO 221 JL=1, KDLON
    5287       ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
    5288       IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
    5289       ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
    5290       IF (ZDSTX.LT.0.5) THEN
    5291          INDT=IXTX
    5292       ELSE
    5293          INDT=IXTX+1
    5294       END IF
    5295       INDB(JL)=INDT
    5296  221  CONTINUE
    5297 C
    5298       DO 224 JF=1,2
    5299       DO 223 JG=1, 8
    5300       DO 222 JL=1, KDLON
    5301       INDT=INDB(JL)
    5302       PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
    5303       PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
    5304  222  CONTINUE
    5305  223  CONTINUE
    5306  224  CONTINUE
    5307  225  CONTINUE
    5308 C
    5309 C     ------------------------------------------------------------------
    5310 C
    5311       RETURN
    5312       END
    5313       SUBROUTINE LWV(KUAER,KTRAER, KLIM
    5314      R  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
    5315      R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
    5316      S  , PCNTRB,PCTS,PFLUC)
    5317        USE dimphy
    5318       IMPLICIT none
    5319 cym#include "dimensions.h"
    5320 cym#include "dimphy.h"
    5321 cym#include "raddim.h"
    5322 #include "raddimlw.h"
    5323 #include "YOMCST.h"
    5324 C
    5325 C-----------------------------------------------------------------------
    5326 C     PURPOSE.
    5327 C     --------
    5328 C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
    5329 C           FLUXES OR RADIANCES
    5330 C
    5331 C     METHOD.
    5332 C     -------
    5333 C
    5334 C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
    5335 C     CONTRIBUTIONS BY -  THE NEARBY LAYERS
    5336 C                      -  THE DISTANT LAYERS
    5337 C                      -  THE BOUNDARY TERMS
    5338 C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
    5339 C
    5340 C     REFERENCE.
    5341 C     ----------
    5342 C
    5343 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    5344 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    5345 C
    5346 C     AUTHOR.
    5347 C     -------
    5348 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    5349 C
    5350 C     MODIFICATIONS.
    5351 C     --------------
    5352 C        ORIGINAL : 89-07-14
    5353 C-----------------------------------------------------------------------
    5354 C
    5355 C* ARGUMENTS:
    5356       INTEGER KUAER,KTRAER, KLIM
    5357 C
    5358       REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
    5359       REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
    5360       REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
    5361       REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
    5362       REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
    5363       REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
    5364       REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
    5365       REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
    5366       REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
    5367       REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
    5368       REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
    5369       REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
    5370       REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
    5371       REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
    5372       REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
    5373       REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
    5374 C
    5375       REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
    5376       REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
    5377       REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
    5378 C-----------------------------------------------------------------------
    5379 C LOCAL VARIABLES:
    5380       REAL*8 ZADJD(KDLON,KFLEV+1)
    5381       REAL*8 ZADJU(KDLON,KFLEV+1)
    5382       REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
    5383       REAL*8 ZDISD(KDLON,KFLEV+1)
    5384       REAL*8 ZDISU(KDLON,KFLEV+1)
    5385 C
    5386       INTEGER jk, jl
    5387 C-----------------------------------------------------------------------
    5388 C
    5389       DO 112 JK=1,KFLEV+1
    5390       DO 111 JL=1, KDLON
    5391       ZADJD(JL,JK)=0.
    5392       ZADJU(JL,JK)=0.
    5393       ZDISD(JL,JK)=0.
    5394       ZDISU(JL,JK)=0.
    5395  111  CONTINUE
    5396  112  CONTINUE
    5397 C
    5398       DO 114 JK=1,KFLEV
    5399       DO 113 JL=1, KDLON
    5400       PCTS(JL,JK)=0.
    5401  113  CONTINUE
    5402  114  CONTINUE
    5403 C
    5404 C* CONTRIBUTION FROM ADJACENT LAYERS
    5405 C
    5406       CALL LWVN(KUAER,KTRAER
    5407      R  , PABCU,PDBSL,PGA,PGB
    5408      S  , ZADJD,ZADJU,PCNTRB,ZDBDT)
    5409 C* CONTRIBUTION FROM DISTANT LAYERS
    5410 C
    5411       CALL LWVD(KUAER,KTRAER
    5412      R  , PABCU,ZDBDT,PGA,PGB
    5413      S  , PCNTRB,ZDISD,ZDISU)
    5414 C
    5415 C* EXCHANGE WITH THE BOUNDARIES
    5416 C
    5417       CALL LWVB(KUAER,KTRAER, KLIM
    5418      R  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
    5419      R  , ZDISD,ZDISU,PEMIS,PPMB
    5420      R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
    5421      S  , PCTS,PFLUC)
    5422 C
    5423 C
    5424       RETURN
    5425       END
    5426       SUBROUTINE LWVB(KUAER,KTRAER, KLIM
    5427      R  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
    5428      R  , PDISD,PDISU,PEMIS,PPMB
    5429      R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
    5430      S  , PCTS,PFLUC)
    5431        USE dimphy
    5432       IMPLICIT none
    5433 cym#include "dimensions.h"
    5434 cym#include "dimphy.h"
    5435 cym#include "raddim.h"
    5436 #include "raddimlw.h"
    5437 #include "radopt.h"
    5438 C
    5439 C-----------------------------------------------------------------------
    5440 C     PURPOSE.
    5441 C     --------
    5442 C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
    5443 C           INTEGRATION
    5444 C
    5445 C     METHOD.
    5446 C     -------
    5447 C
    5448 C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
    5449 C     ATMOSPHERE
    5450 C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
    5451 C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
    5452 C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
    5453 C
    5454 C     REFERENCE.
    5455 C     ----------
    5456 C
    5457 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    5458 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    5459 C
    5460 C     AUTHOR.
    5461 C     -------
    5462 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    5463 C
    5464 C     MODIFICATIONS.
    5465 C     --------------
    5466 C        ORIGINAL : 89-07-14
    5467 C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
    5468 C-----------------------------------------------------------------------
    5469 C
    5470 C*       0.1   ARGUMENTS
    5471 C              ---------
    5472 C
    5473       INTEGER KUAER,KTRAER, KLIM
    5474 C
    5475       REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
    5476       REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
    5477       REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
    5478       REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
    5479       REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
    5480       REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
    5481       REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
    5482       REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
    5483       REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
    5484       REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
    5485       REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
    5486       REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
    5487       REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
    5488       REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
    5489       REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
    5490       REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
    5491       REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
    5492       REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
    5493 C
    5494       REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
    5495       REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
    5496 C
    5497 C* LOCAL VARIABLES:
    5498 C
    5499       REAL*8 ZBGND(KDLON)
    5500       REAL*8 ZFD(KDLON)
    5501       REAL*8  ZFN10(KDLON)
    5502       REAL*8 ZFU(KDLON)
    5503       REAL*8  ZTT(KDLON,NTRA)
    5504       REAL*8 ZTT1(KDLON,NTRA)
    5505       REAL*8 ZTT2(KDLON,NTRA)
    5506       REAL*8  ZUU(KDLON,NUA)
    5507       REAL*8 ZCNSOL(KDLON)
    5508       REAL*8 ZCNTOP(KDLON)
    5509 C
    5510       INTEGER jk, jl, ja
    5511       INTEGER jstra, jstru
    5512       INTEGER ind1, ind2, ind3, ind4, in, jlim
    5513       REAL*8 zctstr
    5514 C-----------------------------------------------------------------------
    5515 C
    5516 C*         1.    INITIALIZATION
    5517 C                --------------
    5518 C
    5519  100  CONTINUE
    5520 C
    5521 C
    5522 C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
    5523 C                  ---------------------------------
    5524 C
    5525  120  CONTINUE
    5526 C
    5527       DO 122 JA=1,NTRA
    5528       DO 121 JL=1, KDLON
    5529       ZTT (JL,JA)=1.0
    5530       ZTT1(JL,JA)=1.0
    5531       ZTT2(JL,JA)=1.0
    5532  121  CONTINUE
    5533  122  CONTINUE
    5534 C
    5535       DO 124 JA=1,NUA
    5536       DO 123 JL=1, KDLON
    5537       ZUU(JL,JA)=1.0
    5538  123  CONTINUE
    5539  124  CONTINUE
    5540 C
    5541 C     ------------------------------------------------------------------
    5542 C
    5543 C*         2.      VERTICAL INTEGRATION
    5544 C                  --------------------
    5545 C
    5546  200  CONTINUE
    5547 C
    5548       IND1=0
    5549       IND3=0
    5550       IND4=1
    5551       IND2=1
    5552 C
    5553 C
    5554 C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
    5555 C                  -----------------------------------
    5556 C
    5557  230  CONTINUE
    5558 C
    5559       DO 235 JK = 1 , KFLEV
    5560       IN=(JK-1)*NG1P1+1
    5561 C
    5562       DO 232 JA=1,KUAER
    5563       DO 231 JL=1, KDLON
    5564       ZUU(JL,JA)=PABCU(JL,JA,IN)
    5565  231  CONTINUE
    5566  232  CONTINUE
    5567 C
    5568 C
    5569       CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
    5570 C
    5571       DO 234 JL = 1, KDLON
    5572       ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
    5573      2      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
    5574      3      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
    5575      4      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
    5576      5      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
    5577      6      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
    5578       ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
    5579       PFLUC(JL,2,JK)=ZFD(JL)
    5580  234  CONTINUE
    5581 C
    5582  235  CONTINUE
    5583 C
    5584       JK = KFLEV+1
    5585       IN=(JK-1)*NG1P1+1
    5586 C
    5587       DO 236 JL = 1, KDLON
    5588       ZCNTOP(JL)= PBTOP(JL,1)
    5589      1   + PBTOP(JL,2)
    5590      2   + PBTOP(JL,3)
    5591      3   + PBTOP(JL,4)
    5592      4   + PBTOP(JL,5)
    5593      5   + PBTOP(JL,6)
    5594       ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
    5595       PFLUC(JL,2,JK)=ZFD(JL)
    5596  236  CONTINUE
    5597 C
    5598 C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
    5599 C                  ---------------------------------------
    5600 C
    5601  240  CONTINUE
    5602 C
    5603 C
    5604 C*         2.4.1   INITIALIZATION
    5605 C                  --------------
    5606 C
    5607  2410 CONTINUE
    5608 C
    5609       JLIM = KFLEV
    5610 C
    5611       IF (.NOT.LEVOIGT) THEN
    5612       DO 2412 JK = KFLEV,1,-1
    5613       IF(PPMB(1,JK).LT.10.0) THEN
    5614          JLIM=JK
    5615       ENDIF   
    5616  2412 CONTINUE
    5617       ENDIF
    5618       KLIM=JLIM
    5619 C
    5620       IF (.NOT.LEVOIGT) THEN
    5621         DO 2414 JA=1,KTRAER
    5622         DO 2413 JL=1, KDLON
    5623         ZTT1(JL,JA)=1.0
    5624  2413   CONTINUE
    5625  2414   CONTINUE
    5626 C
    5627 C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
    5628 C                  -----------------------------
    5629 C
    5630  2420   CONTINUE
    5631 C
    5632         DO 2427 JSTRA = KFLEV,JLIM,-1
    5633         JSTRU=(JSTRA-1)*NG1P1+1
    5634 C
    5635         DO 2423 JA=1,KUAER
    5636         DO 2422 JL=1, KDLON
    5637         ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
    5638  2422   CONTINUE
    5639  2423   CONTINUE
    5640 C
    5641 C
    5642         CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
    5643 C
    5644         DO 2424 JL = 1, KDLON
    5645         ZCTSTR =
    5646      1   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
    5647      1       *(ZTT1(JL,1)           *ZTT1(JL,10)
    5648      1       - ZTT (JL,1)           *ZTT (JL,10))
    5649      2  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
    5650      2       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)
    5651      2       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))
    5652      3  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
    5653      3       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)
    5654      3       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))
    5655      4  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
    5656      4       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)
    5657      4       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))
    5658      5  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
    5659      5       *(ZTT1(JL,3)           *ZTT1(JL,14)
    5660      5       - ZTT (JL,3)           *ZTT (JL,14))
    5661      6  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
    5662      6       *(ZTT1(JL,6)           *ZTT1(JL,15)
    5663      6       - ZTT (JL,6)           *ZTT (JL,15))
    5664         PCTS(JL,JSTRA)=ZCTSTR*0.5
    5665  2424   CONTINUE
    5666         DO 2426 JA=1,KTRAER
    5667         DO 2425 JL=1, KDLON
    5668         ZTT1(JL,JA)=ZTT(JL,JA)
    5669  2425   CONTINUE
    5670  2426   CONTINUE
    5671  2427   CONTINUE
    5672       ENDIF
    5673 C Mise a zero de securite pour PCTS en cas de LEVOIGT
    5674       IF(LEVOIGT)THEN
    5675         DO 2429 JSTRA = 1,KFLEV
    5676         DO 2428 JL = 1, KDLON
    5677           PCTS(JL,JSTRA)=0.
    5678  2428   CONTINUE
    5679  2429   CONTINUE
    5680       ENDIF
    5681 C
    5682 C
    5683 C*         2.5     EXCHANGE WITH LOWER LIMIT
    5684 C                  -------------------------
    5685 C
    5686  250  CONTINUE
    5687 C
    5688       DO 251 JL = 1, KDLON
    5689       ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
    5690      S               *PFLUC(JL,2,1)-PBINT(JL,1)
    5691  251  CONTINUE
    5692 C
    5693       JK = 1
    5694       IN=(JK-1)*NG1P1+1
    5695 C
    5696       DO 252 JL = 1, KDLON
    5697       ZCNSOL(JL)=PBSUR(JL,1)
    5698      1 +PBSUR(JL,2)
    5699      2 +PBSUR(JL,3)
    5700      3 +PBSUR(JL,4)
    5701      4 +PBSUR(JL,5)
    5702      5 +PBSUR(JL,6)
    5703       ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
    5704       ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
    5705       PFLUC(JL,1,JK)=ZFU(JL)
    5706  252  CONTINUE
    5707 C
    5708       DO 257 JK = 2 , KFLEV+1
    5709       IN=(JK-1)*NG1P1+1
    5710 C
    5711 C
    5712       DO 255 JA=1,KUAER
    5713       DO 254 JL=1, KDLON
    5714       ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
    5715  254  CONTINUE
    5716  255  CONTINUE
    5717 C
    5718 C
    5719       CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
    5720 C
    5721       DO 256 JL = 1, KDLON
    5722       ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
    5723      2      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
    5724      3      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
    5725      4      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
    5726      5      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
    5727      6      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
    5728       ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
    5729       ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
    5730       PFLUC(JL,1,JK)=ZFU(JL)
    5731  256  CONTINUE
    5732 C
    5733 C
    5734  257  CONTINUE
    5735 C
    5736 C
    5737 C
    5738 C*         2.7     CLEAR-SKY FLUXES
    5739 C                  ----------------
    5740 C
    5741  270  CONTINUE
    5742 C
    5743       IF (.NOT.LEVOIGT) THEN
    5744       DO 271 JL = 1, KDLON
    5745       ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
    5746  271  CONTINUE
    5747       DO 273 JK = JLIM+1,KFLEV+1
    5748       DO 272 JL = 1, KDLON
    5749       ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
    5750       PFLUC(JL,1,JK) = ZFN10(JL)
    5751       PFLUC(JL,2,JK) = 0.
    5752  272  CONTINUE
    5753  273  CONTINUE
    5754       ENDIF
    5755 C
    5756 C     ------------------------------------------------------------------
    5757 C
    5758       RETURN
    5759       END
    5760       SUBROUTINE LWVD(KUAER,KTRAER
    5761      S  , PABCU,PDBDT
    5762      R  , PGA,PGB
    5763      S  , PCNTRB,PDISD,PDISU)
    5764       USE dimphy
    5765       IMPLICIT none
    5766 cym#include "dimensions.h"
    5767 cym#include "dimphy.h"
    5768 cym#include "raddim.h"
    5769 #include "raddimlw.h"
    5770 C
    5771 C-----------------------------------------------------------------------
    5772 C     PURPOSE.
    5773 C     --------
    5774 C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
    5775 C
    5776 C     METHOD.
    5777 C     -------
    5778 C
    5779 C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
    5780 C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
    5781 C
    5782 C     REFERENCE.
    5783 C     ----------
    5784 C
    5785 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    5786 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    5787 C
    5788 C     AUTHOR.
    5789 C     -------
    5790 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    5791 C
    5792 C     MODIFICATIONS.
    5793 C     --------------
    5794 C        ORIGINAL : 89-07-14
    5795 C-----------------------------------------------------------------------
    5796 C* ARGUMENTS:
    5797 C
    5798       INTEGER KUAER,KTRAER
    5799 C
    5800       REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
    5801       REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
    5802       REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
    5803       REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
    5804 C
    5805       REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
    5806       REAL*8 PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
    5807       REAL*8 PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
    5808 C
    5809 C* LOCAL VARIABLES:
    5810 C
    5811       REAL*8 ZGLAYD(KDLON)
    5812       REAL*8 ZGLAYU(KDLON)
    5813       REAL*8 ZTT(KDLON,NTRA)
    5814       REAL*8 ZTT1(KDLON,NTRA)
    5815       REAL*8 ZTT2(KDLON,NTRA)
    5816 C
    5817       INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
    5818       INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
    5819       INTEGER ind1, ind2, ind3, ind4, itt
    5820       REAL*8 zww, zdzxdg, zdzxmg
    5821 C
    5822 C*         1.    INITIALIZATION
    5823 C                --------------
    5824 C
    5825  100  CONTINUE
    5826 C
    5827 C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
    5828 C                  ------------------------------
    5829 C
    5830  110  CONTINUE
    5831 C
    5832       DO 112 JK = 1, KFLEV+1
    5833       DO 111 JL = 1, KDLON
    5834       PDISD(JL,JK) = 0.
    5835       PDISU(JL,JK) = 0.
    5836   111 CONTINUE
    5837   112 CONTINUE
    5838 C
    5839 C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
    5840 C                  ---------------------------------
    5841 C
    5842  120  CONTINUE
    5843 C
    5844 C
    5845       DO 122 JA = 1, NTRA
    5846       DO 121 JL = 1, KDLON
    5847       ZTT (JL,JA) = 1.0
    5848       ZTT1(JL,JA) = 1.0
    5849       ZTT2(JL,JA) = 1.0
    5850   121 CONTINUE
    5851   122 CONTINUE
    5852 C
    5853 C     ------------------------------------------------------------------
    5854 C
    5855 C*         2.      VERTICAL INTEGRATION
    5856 C                  --------------------
    5857 C
    5858  200  CONTINUE
    5859 C
    5860       IND1=0
    5861       IND3=0
    5862       IND4=1
    5863       IND2=1
    5864 C
    5865 C
    5866 C*         2.2     CONTRIBUTION FROM DISTANT LAYERS
    5867 C                  ---------------------------------
    5868 C
    5869  220  CONTINUE
    5870 C
    5871 C
    5872 C*         2.2.1   DISTANT AND ABOVE LAYERS
    5873 C                  ------------------------
    5874 C
    5875  2210 CONTINUE
    5876 C
    5877 C
    5878 C
    5879 C*         2.2.2   FIRST UPPER LEVEL
    5880 C                  -----------------
    5881 C
    5882  2220 CONTINUE
    5883 C
    5884       DO 225 JK = 1 , KFLEV-1
    5885       IKP1=JK+1
    5886       IKN=(JK-1)*NG1P1+1
    5887       IKD1= JK  *NG1P1+1
    5888 C
    5889       CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
    5890      2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
    5891 C
    5892 C
    5893 C
    5894 C*         2.2.3   HIGHER UP
    5895 C                  ---------
    5896 C
    5897  2230 CONTINUE
    5898 C
    5899       ITT=1
    5900       DO 224 JKJ=IKP1,KFLEV
    5901       IF(ITT.EQ.1) THEN
    5902          ITT=2
    5903       ELSE
    5904          ITT=1
    5905       ENDIF
    5906       IKJP1=JKJ+1
    5907       IKD2= JKJ  *NG1P1+1
    5908 C
    5909       IF(ITT.EQ.1) THEN
    5910          CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
    5911      2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
    5912       ELSE
    5913          CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
    5914      2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
    5915       ENDIF
    5916 C
    5917       DO 2235 JA = 1, KTRAER
    5918       DO 2234 JL = 1, KDLON
    5919       ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
    5920  2234 CONTINUE
    5921  2235 CONTINUE
    5922 C
    5923       DO 2236 JL = 1, KDLON
    5924       ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
    5925      S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
    5926      S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
    5927      S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
    5928      S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
    5929      S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
    5930       ZGLAYD(JL)=ZWW
    5931       ZDZXDG=ZGLAYD(JL)
    5932       PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
    5933       PCNTRB(JL,JK,IKJP1)=ZDZXDG
    5934  2236 CONTINUE
    5935 C
    5936 C
    5937  224  CONTINUE
    5938  225  CONTINUE
    5939 C
    5940 C
    5941 C*         2.2.4   DISTANT AND BELOW LAYERS
    5942 C                  ------------------------
    5943 C
    5944  2240 CONTINUE
    5945 C
    5946 C
    5947 C
    5948 C*         2.2.5   FIRST LOWER LEVEL
    5949 C                  -----------------
    5950 C
    5951  2250 CONTINUE
    5952 C
    5953       DO 228 JK=3,KFLEV+1
    5954       IKN=(JK-1)*NG1P1+1
    5955       IKM1=JK-1
    5956       IKJ=JK-2
    5957       IKU1= IKJ  *NG1P1+1
    5958 C
    5959 C
    5960       CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
    5961      2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
    5962 C
    5963 C
    5964 C
    5965 C*         2.2.6   DOWN BELOW
    5966 C                  ----------
    5967 C
    5968  2260 CONTINUE
    5969 C
    5970       ITT=1
    5971       DO 227 JLK=1,IKJ
    5972       IF(ITT.EQ.1) THEN
    5973          ITT=2
    5974       ELSE
    5975          ITT=1
    5976       ENDIF
    5977       IJKL=IKM1-JLK
    5978       IKU2=(IJKL-1)*NG1P1+1
    5979 C
    5980 C
    5981       IF(ITT.EQ.1) THEN
    5982          CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
    5983      2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
    5984       ELSE
    5985          CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
    5986      2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
    5987       ENDIF
    5988 C
    5989       DO 2265 JA = 1, KTRAER
    5990       DO 2264 JL = 1, KDLON
    5991       ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
    5992  2264 CONTINUE
    5993  2265 CONTINUE
    5994 C
    5995       DO 2266 JL = 1, KDLON
    5996       ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)
    5997      S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
    5998      S   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
    5999      S   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
    6000      S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)
    6001      S   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
    6002       ZGLAYU(JL)=ZWW
    6003       ZDZXMG=ZGLAYU(JL)
    6004       PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
    6005       PCNTRB(JL,JK,IJKL)=ZDZXMG
    6006  2266 CONTINUE
    6007 C
    6008 C
    6009  227  CONTINUE
    6010  228  CONTINUE
    6011 C
    6012       RETURN
    6013       END
    6014       SUBROUTINE LWVN(KUAER,KTRAER
    6015      R  , PABCU,PDBSL,PGA,PGB
    6016      S  , PADJD,PADJU,PCNTRB,PDBDT)
    6017        USE dimphy
    6018       IMPLICIT none
    6019 cym#include "dimensions.h"
    6020 cym#include "dimphy.h"
    6021 cym#include "raddim.h"
    6022 #include "raddimlw.h"
    6023 C
    6024 C-----------------------------------------------------------------------
    6025 C     PURPOSE.
    6026 C     --------
    6027 C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
    6028 C           TO GIVE LONGWAVE FLUXES OR RADIANCES
    6029 C
    6030 C     METHOD.
    6031 C     -------
    6032 C
    6033 C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
    6034 C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
    6035 C
    6036 C     REFERENCE.
    6037 C     ----------
    6038 C
    6039 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    6040 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    6041 C
    6042 C     AUTHOR.
    6043 C     -------
    6044 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    6045 C
    6046 C     MODIFICATIONS.
    6047 C     --------------
    6048 C        ORIGINAL : 89-07-14
    6049 C-----------------------------------------------------------------------
    6050 C
    6051 C* ARGUMENTS:
    6052 C
    6053       INTEGER KUAER,KTRAER
    6054 C
    6055       REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
    6056       REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
    6057       REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
    6058       REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
    6059 C
    6060       REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
    6061       REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
    6062       REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
    6063       REAL*8 PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
    6064 C
    6065 C* LOCAL ARRAYS:
    6066 C
    6067       REAL*8 ZGLAYD(KDLON)
    6068       REAL*8 ZGLAYU(KDLON)
    6069       REAL*8 ZTT(KDLON,NTRA)
    6070       REAL*8 ZTT1(KDLON,NTRA)
    6071       REAL*8 ZTT2(KDLON,NTRA)
    6072       REAL*8 ZUU(KDLON,NUA)
    6073 C
    6074       INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
    6075       INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
    6076       REAL*8 zwtr
    6077 c
    6078 C* Data Block:
    6079 c
    6080       REAL*8 WG1(2)
    6081       SAVE WG1
    6082 c$OMP THREADPRIVATE(WG1)
    6083       DATA (WG1(jk),jk=1,2) /1.0, 1.0/
    6084 C-----------------------------------------------------------------------
    6085 C
    6086 C*         1.    INITIALIZATION
    6087 C                --------------
    6088 C
    6089  100  CONTINUE
    6090 C
    6091 C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
    6092 C                  ------------------------------
    6093 C
    6094  110  CONTINUE
    6095 C
    6096       DO 112 JK = 1 , KFLEV+1
    6097       DO 111 JL = 1, KDLON
    6098       PADJD(JL,JK) = 0.
    6099       PADJU(JL,JK) = 0.
    6100  111  CONTINUE
    6101  112  CONTINUE
    6102 C
    6103 C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
    6104 C                  ---------------------------------
    6105 C
    6106  120  CONTINUE
    6107 C
    6108       DO 122 JA = 1 , NTRA
    6109       DO 121 JL = 1, KDLON
    6110       ZTT (JL,JA) = 1.0
    6111       ZTT1(JL,JA) = 1.0
    6112       ZTT2(JL,JA) = 1.0
    6113  121  CONTINUE
    6114  122  CONTINUE
    6115 C
    6116       DO 124 JA = 1 , NUA
    6117       DO 123 JL = 1, KDLON
    6118       ZUU(JL,JA) = 0.
    6119  123  CONTINUE
    6120  124  CONTINUE
    6121 C
    6122 C     ------------------------------------------------------------------
    6123 C
    6124 C*         2.      VERTICAL INTEGRATION
    6125 C                  --------------------
    6126 C
    6127  200  CONTINUE
    6128 C
    6129 C
    6130 C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
    6131 C                  ---------------------------------
    6132 C
    6133  210  CONTINUE
    6134 C
    6135       DO 215 JK = 1 , KFLEV
    6136 C
    6137 C*         2.1.1   DOWNWARD LAYERS
    6138 C                  ---------------
    6139 C
    6140  2110 CONTINUE
    6141 C
    6142       IM12 = 2 * (JK - 1)
    6143       IND = (JK - 1) * NG1P1 + 1
    6144       IXD = IND
    6145       INU = JK * NG1P1 + 1
    6146       IXU = IND
    6147 C
    6148       DO 2111 JL = 1, KDLON
    6149       ZGLAYD(JL) = 0.
    6150       ZGLAYU(JL) = 0.
    6151  2111 CONTINUE
    6152 C
    6153       DO 213 JG = 1 , NG1
    6154       IBS = IM12 + JG
    6155       IDD = IXD + JG
    6156       DO 2113 JA = 1 , KUAER
    6157       DO 2112 JL = 1, KDLON
    6158       ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
    6159  2112 CONTINUE
    6160  2113 CONTINUE
    6161 C
    6162 C
    6163       CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
    6164 C
    6165       DO 2114 JL = 1, KDLON
    6166       ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
    6167      S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
    6168      S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
    6169      S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
    6170      S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
    6171      S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
    6172       ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
    6173  2114 CONTINUE
    6174 C
    6175 C*         2.1.2   DOWNWARD LAYERS
    6176 C                  ---------------
    6177 C
    6178  2120 CONTINUE
    6179 C
    6180       IMU = IXU + JG
    6181       DO 2122 JA = 1 , KUAER
    6182       DO 2121 JL = 1, KDLON
    6183       ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
    6184  2121 CONTINUE
    6185  2122 CONTINUE
    6186 C
    6187 C
    6188       CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
    6189 C
    6190       DO 2123 JL = 1, KDLON
    6191       ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
    6192      S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
    6193      S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
    6194      S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
    6195      S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
    6196      S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
    6197       ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
    6198  2123 CONTINUE
    6199 C
    6200  213  CONTINUE
    6201 C
    6202       DO 214 JL = 1, KDLON
    6203       PADJD(JL,JK) = ZGLAYD(JL)
    6204       PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
    6205       PADJU(JL,JK+1) = ZGLAYU(JL)
    6206       PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
    6207       PCNTRB(JL,JK  ,JK) = 0.0
    6208  214  CONTINUE
    6209 C
    6210  215  CONTINUE
    6211 C
    6212       DO 218 JK = 1 , KFLEV
    6213       JK2 = 2 * JK
    6214       JK1 = JK2 - 1
    6215       DO 217 JNU = 1 , Ninter
    6216       DO 216 JL = 1, KDLON
    6217       PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
    6218  216  CONTINUE
    6219  217  CONTINUE
    6220  218  CONTINUE
    6221 C
    6222       RETURN
    6223 C
    6224       END
    6225       SUBROUTINE LWTT(PGA,PGB,PUU, PTT)
    6226        USE dimphy
    6227       IMPLICIT none
    6228 cym#include "dimensions.h"
    6229 cym#include "dimphy.h"
    6230 cym#include "raddim.h"
    6231 #include "raddimlw.h"
    6232 C
    6233 C-----------------------------------------------------------------------
    6234 C     PURPOSE.
    6235 C     --------
    6236 C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
    6237 C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
    6238 C     INTERVALS.
    6239 C
    6240 C     METHOD.
    6241 C     -------
    6242 C
    6243 C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
    6244 C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
    6245 C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
    6246 C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
    6247 C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
    6248 C
    6249 C     REFERENCE.
    6250 C     ----------
    6251 C
    6252 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    6253 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    6254 C
    6255 C     AUTHOR.
    6256 C     -------
    6257 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    6258 C
    6259 C     MODIFICATIONS.
    6260 C     --------------
    6261 C        ORIGINAL : 88-12-15
    6262 C
    6263 C-----------------------------------------------------------------------
    6264       REAL*8 O1H, O2H
    6265       PARAMETER (O1H=2230.)
    6266       PARAMETER (O2H=100.)
    6267       REAL*8 RPIALF0
    6268       PARAMETER (RPIALF0=2.0)
    6269 C
    6270 C* ARGUMENTS:
    6271 C
    6272       REAL*8 PUU(KDLON,NUA)
    6273       REAL*8 PTT(KDLON,NTRA)
    6274       REAL*8 PGA(KDLON,8,2)
    6275       REAL*8 PGB(KDLON,8,2)
    6276 C
    6277 C* LOCAL VARIABLES:
    6278 C
    6279       REAL*8 zz, zxd, zxn
    6280       REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
    6281       REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
    6282       REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
    6283       REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
    6284       REAL*8 zsqn21, zodn21, zsqh42, zodh42
    6285       REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
    6286       REAL*8 zuu11, zuu12, za11, za12
    6287       INTEGER jl, ja
    6288 C     ------------------------------------------------------------------
    6289 C
    6290 C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
    6291 C                 -----------------------------------------------
    6292 C
    6293  100  CONTINUE
    6294 C
    6295 C
    6296       DO 130 JA = 1 , 8
    6297       DO 120 JL = 1, KDLON
    6298       ZZ      =SQRT(PUU(JL,JA))
    6299 c     ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
    6300 c     ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
    6301 c     PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
    6302       ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
    6303       ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
    6304       PTT(JL,JA)=ZXN      /ZXD
    6305   120 CONTINUE
    6306   130 CONTINUE
    6307 C
    6308 C     ------------------------------------------------------------------
    6309 C
    6310 C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
    6311 C                 ---------------------------------------------------
    6312 C
    6313  200  CONTINUE
    6314 C
    6315       DO 201 JL = 1, KDLON
    6316       PTT(JL, 9) = PTT(JL, 8)
    6317 C
    6318 C-  CONTINUUM ABSORPTION: E- AND P-TYPE
    6319 C
    6320       ZPU   = 0.002 * PUU(JL,10)
    6321       ZPU10 = 112. * ZPU
    6322       ZPU11 = 6.25 * ZPU
    6323       ZPU12 = 5.00 * ZPU
    6324       ZPU13 = 80.0 * ZPU
    6325       ZEU   =  PUU(JL,11)
    6326       ZEU10 =  12. * ZEU
    6327       ZEU11 = 6.25 * ZEU
    6328       ZEU12 = 5.00 * ZEU
    6329       ZEU13 = 80.0 * ZEU
    6330 C
    6331 C-  OZONE ABSORPTION
    6332 C
    6333       ZX = PUU(JL,12)
    6334       ZY = PUU(JL,13)
    6335       ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
    6336       ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
    6337       ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
    6338       ZVXY = RPIALF0 * ZY / (2. * ZX)
    6339       ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
    6340       ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
    6341       ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
    6342 C
    6343 C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
    6344 C
    6345 C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
    6346 C
    6347 c     NEXOTIC=1
    6348 c     IF (NEXOTIC.EQ.1) THEN
    6349       ZXCH4 = PUU(JL,19)
    6350       ZYCH4 = PUU(JL,20)
    6351       ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
    6352       ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
    6353       ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
    6354       ZODH41 = ZVXY * ZSQH41
    6355 C
    6356 C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
    6357 C
    6358       ZXN2O = PUU(JL,21)
    6359       ZYN2O = PUU(JL,22)
    6360       ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
    6361       ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
    6362       ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
    6363       ZODN21 = ZVXY * ZSQN21
    6364 C
    6365 C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
    6366 C
    6367       ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
    6368       ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
    6369       ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
    6370       ZODH42 = ZVXY * ZSQH42
    6371 C
    6372 C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
    6373 C
    6374       ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
    6375       ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
    6376       ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
    6377       ZODN22 = ZVXY * ZSQN22
    6378 C
    6379 C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
    6380 C
    6381       ZA11 = 2. * PUU(JL,23) * 4.404E+05
    6382       ZTTF11 = 1. - ZA11 * 0.003225
    6383 C
    6384 C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
    6385 C
    6386       ZA12 = 2. * PUU(JL,24) * 6.7435E+05
    6387       ZTTF12 = 1. - ZA12 * 0.003225
    6388 C
    6389       ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
    6390       ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
    6391       PTT(JL,10) = EXP( - PUU(JL,14) )
    6392       PTT(JL,11) = EXP( ZUU11 )
    6393       PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
    6394       PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
    6395       PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
    6396       PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
    6397  201  CONTINUE
    6398 C
    6399       RETURN
    6400       END
    6401       SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)
    6402       USE dimphy
    6403       IMPLICIT none
    6404 cym#include "dimensions.h"
    6405 cym#include "dimphy.h"
    6406 cym#include "raddim.h"
    6407 #include "raddimlw.h"
    6408 C
    6409 C     ------------------------------------------------------------------
    6410 C     PURPOSE.
    6411 C     --------
    6412 C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
    6413 C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
    6414 C     INTERVALS.
    6415 C
    6416 C     METHOD.
    6417 C     -------
    6418 C
    6419 C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
    6420 C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
    6421 C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
    6422 C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
    6423 C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
    6424 C
    6425 C     REFERENCE.
    6426 C     ----------
    6427 C
    6428 C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
    6429 C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
    6430 C
    6431 C     AUTHOR.
    6432 C     -------
    6433 C        JEAN-JACQUES MORCRETTE  *ECMWF*
    6434 C
    6435 C     MODIFICATIONS.
    6436 C     --------------
    6437 C        ORIGINAL : 88-12-15
    6438 C
    6439 C-----------------------------------------------------------------------
    6440       REAL*8 O1H, O2H
    6441       PARAMETER (O1H=2230.)
    6442       PARAMETER (O2H=100.)
    6443       REAL*8 RPIALF0
    6444       PARAMETER (RPIALF0=2.0)
    6445 C
    6446 C* ARGUMENTS:
    6447 C
    6448       REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
    6449       REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
    6450       REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
    6451       REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
    6452       REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
    6453 C
    6454 C* LOCAL VARIABLES:
    6455 C
    6456       INTEGER ja, jl
    6457       REAL*8 zz, zxd, zxn
    6458       REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
    6459       REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
    6460       REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
    6461       REAL*8 zxch4, zych4, zsqh41, zodh41
    6462       REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
    6463       REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
    6464       REAL*8 zuu11, zuu12
    6465 C     ------------------------------------------------------------------
    6466 C
    6467 C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
    6468 C                 -----------------------------------------------
    6469 C
    6470  100  CONTINUE
    6471 C
    6472 C
    6473       DO 130 JA = 1 , 8
    6474       DO 120 JL = 1, KDLON
    6475       ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
    6476       ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
    6477       ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
    6478       PTT(JL,JA)=ZXN      /ZXD
    6479   120 CONTINUE
    6480   130 CONTINUE
    6481 C
    6482 C     ------------------------------------------------------------------
    6483 C
    6484 C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
    6485 C                 ---------------------------------------------------
    6486 C
    6487  200  CONTINUE
    6488 C
    6489       DO 201 JL = 1, KDLON
    6490       PTT(JL, 9) = PTT(JL, 8)
    6491 C
    6492 C-  CONTINUUM ABSORPTION: E- AND P-TYPE
    6493 C
    6494       ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
    6495       ZPU10 = 112. * ZPU
    6496       ZPU11 = 6.25 * ZPU
    6497       ZPU12 = 5.00 * ZPU
    6498       ZPU13 = 80.0 * ZPU
    6499       ZEU   = (PUU1(JL,11) - PUU2(JL,11))
    6500       ZEU10 =  12. * ZEU
    6501       ZEU11 = 6.25 * ZEU
    6502       ZEU12 = 5.00 * ZEU
    6503       ZEU13 = 80.0 * ZEU
    6504 C
    6505 C-  OZONE ABSORPTION
    6506 C
    6507       ZX = (PUU1(JL,12) - PUU2(JL,12))
    6508       ZY = (PUU1(JL,13) - PUU2(JL,13))
    6509       ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
    6510       ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
    6511       ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
    6512       ZVXY = RPIALF0 * ZY / (2. * ZX)
    6513       ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
    6514       ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
    6515       ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
    6516 C
    6517 C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
    6518 C
    6519 C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
    6520 C
    6521       ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
    6522       ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
    6523       ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
    6524       ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
    6525       ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
    6526       ZODH41 = ZVXY * ZSQH41
    6527 C
    6528 C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
    6529 C
    6530       ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
    6531       ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
    6532       ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
    6533       ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
    6534       ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
    6535       ZODN21 = ZVXY * ZSQN21
    6536 C
    6537 C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
    6538 C
    6539       ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
    6540       ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
    6541       ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
    6542       ZODH42 = ZVXY * ZSQH42
    6543 C
    6544 C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
    6545 C
    6546       ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
    6547       ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
    6548       ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
    6549       ZODN22 = ZVXY * ZSQN22
    6550 C
    6551 C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
    6552 C
    6553       ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
    6554       ZTTF11 = 1. - ZA11 * 0.003225
    6555 C
    6556 C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
    6557 C
    6558       ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
    6559       ZTTF12 = 1. - ZA12 * 0.003225
    6560 C
    6561       ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
    6562       ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
    6563      S         ZODH41 - ZODN21
    6564       PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
    6565       PTT(JL,11) = EXP( ZUU11 )
    6566       PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
    6567       PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
    6568       PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
    6569       PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
    6570  201  CONTINUE
    6571 C
    6572       RETURN
    6573       END
Note: See TracChangeset for help on using the changeset viewer.