*=*=*=*= SW2S.html =*=*=*=*
SUBROUTINE SW2S

SUBROUTINE SW2S


      SUBROUTINE SW2S ( KDLON, KFLEV, KAER, KNU
     S  ,  PAER,PAKI,PALBS,PCG,PCLDSW,PDSIG,POMEGA,PRMU,PSEC,PTAU
     S  ,  PUD,PUM
     S  ,  PFDOWN,PFUP                                                )
      IMPLICIT LOGICAL (L)
C
#include "dimensions.h"
#include "dimphys.h"
#include "dimradmars.h"
C
C**** *SW2* - SHORTWAVE RADIATION, 2ND SPECTRAL INTERVAL
C
C     PURPOSE.
C     --------
C
C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
C
C**   INTERFACE.
C     ----------
C     SUBROUTINE SW2S ( KDLON, KFLEV, KAER, KNU
C    S  ,  PAER,PAKI,PALBS,PCG,PCLDSW,PDSIG,POMEGA,PRMU,PSEC,PTAU
C    S  ,  PUD,PUM
C    S  ,  PFDOWN,PFUP                                                )
C
C          *SW2S* IS CALLED FROM *SW*.
C
C
C        IMPLICIT ARGUMENTS :
C        --------------------
C
C     ==== INPUTS ===
C     ==== OUTPUTS ===
C
C     METHOD.
C     -------
C
C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
C     CONTINUUM SCATTERING
C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
C     A GREY MOLECULAR ABSORPTION
C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
C     OF ABSORBERS
C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
C
C     EXTERNALS.
C     ----------
C
C          *SWR*, *DEDD*, *SWTT*
C
C     REFERENCE.
C     ----------
C
C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
C
C     AUTHOR.
C     -------
C        JEAN-JACQUES MORCRETTE  *ECMWF*
C
C     MODIFICATIONS.
C     --------------
C        ORIGINAL : 89-07-14
C     ------------------------------------------------------------------
C
C
C
C
C-----------------------------------------------------------------------
C
#include "yomcst.h"
#include "yomrad.h"
#include "yomaer.h"
#include "yomlw.h"
#include "yomsw.h"
#include "yomrdu.h"
C
C-----------------------------------------------------------------------
C
C
C*       0.1   ARGUMENTS
C              ---------
C
      REAL PAER(NDLO2,KFLEV,5), PAKI(NDLO2,2), PALBS(NDLO2,2)
     S  ,  PCG(NDLO2,2,KFLEV), PCLDSW(NDLO2,KFLEV), PDSIG(NDLO2,KFLEV)
     S  ,  POMEGA(NDLO2,2,KFLEV), PRMU(NDLO2), PSEC(NDLO2)
     S  ,  PTAU(NDLO2,2,KFLEV), PUD(NDLO2,3,KFLEV+1)
     S  ,  PUM(NDLO2,KFLEV+1)
C
      REAL PFDOWN(NDLO2,KFLEV+1),PFUP(NDLO2,KFLEV+1)
C
C     ------------------------------------------------------------------
C
C*       0.2   LOCAL ARRAYS
C              ------------
C
      REAL ZCGAZ(NDLON,NFLEV), ZG(NDLON), ZGG(NDLON)
     S  ,  ZPIZAZ(NDLON,NFLEV), ZRAYL(NDLON), ZRAY1(NDLON,NFLEV+1)
     S  ,  ZRAY2(NDLON,NFLEV+1), ZREF(NDLON), ZREFZ(NDLON,2,NFLEV+1)
     S  ,  ZRE1(NDLON), ZRE2(NDLON), ZRJ(NDLON,6,NFLEV+1)
     S  ,  ZRK(NDLON,6,NFLEV+1), ZRL(NDLON,8),  ZRMUE(NDLON,NFLEV+1)
     S  ,  ZRMUZ(NDLON), ZRNEB(NDLON),  ZRUEF(NDLON,8), ZR1(NDLON)
     S  ,  ZR2(NDLON), ZR21(NDLON), ZR22(NDLON), ZS(NDLON)
     S  ,  ZTAUAZ(NDLON,NFLEV), ZTO1(NDLON), ZTR(NDLON,2,NFLEV+1)
     S  ,  ZTRA1(NDLON,NFLEV+1), ZTRA2(NDLON,NFLEV+1)
     S  ,  ZTR1(NDLON), ZTR2(NDLON), ZW(NDLON), ZW1(NDLON), ZW2(NDLON)
C
C     ------------------------------------------------------------------
C
C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
C                 -------------------------------------------
C
 100  CONTINUE
C
C
C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
C                 -----------------------------------------
C
 110  CONTINUE
C
      DO 111 JL = 1 , KDLON
      ZRMUM1 = 1. - PRMU(JL)
      ZRAYL(JL) = CRAY(KNU,1) + ZRMUM1   * (CRAY(KNU,2) + ZRMUM1
     S          * (CRAY(KNU,3) + ZRMUM1   * (CRAY(KNU,4) + ZRMUM1
     S          * (CRAY(KNU,5) + ZRMUM1   *  CRAY(KNU,6)       ))))
 111  CONTINUE
C
C
C     ------------------------------------------------------------------
C
C*         2.    CONTINUUM SCATTERING CALCULATIONS
C                ---------------------------------
C
 200  CONTINUE
C
      CALL SWR ( KDLON, KFLEV, KAER, KNU
     S  , PAER, PALBS, PCG, PCLDSW, PDSIG, POMEGA, ZRAYL, PSEC, PTAU
     S  , ZCGAZ, ZPIZAZ, ZRAY1, ZRAY2, ZREFZ, ZRJ, ZRK, ZRMUE
     S  , ZTAUAZ, ZTRA1, ZTRA2 )
C
C
C     ------------------------------------------------------------------
C
C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
C                ------------------------------------------------------
C
 300  CONTINUE
C
      JN = 2
C
      DO 361 JABS=1,2
C
C
C*         3.1  SURFACE CONDITIONS
C               ------------------
C
 310  CONTINUE
C
      DO 311 JL = 1 , KDLON
      ZREFZ(JL,2,1) = PALBS(JL,KNU)
      ZREFZ(JL,1,1) = PALBS(JL,KNU)
 311  CONTINUE
C
C
C*         3.2  INTRODUCING CLOUD EFFECTS
C               -------------------------
C
 320  CONTINUE
C
      DO 324 JK = 2 , KFLEV+1
      JKM1 = JK - 1
      DO 322 JL = 1 , KDLON
      ZRNEB(JL) = PCLDSW(JL,JKM1)
      ZAA = PUD(JL,JABS,JKM1)
      ZRKI = PAKI(JL,JABS)
      ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
      ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
      ZTR1(JL) = 0.
      ZRE1(JL) = 0.
      ZTR2(JL) = 0.
      ZRE2(JL) = 0.
C
      PTAU(JL,KNU,JKM1) = AMAX1( PTAU(JL,KNU,JKM1) , ZEPSCT )
      ZW(JL)= POMEGA(JL,KNU,JKM1)
      ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
     S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
     S               + ZAA * ZRKI
      ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
     S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
      ZW(JL) = ZR21(JL) / ZTO1(JL)
      ZREF(JL) = ZREFZ(JL,1,JKM1)
      ZRMUZ(JL) = ZRMUE(JL,JK)
 322  CONTINUE
C
      CALL DEDD ( KDLON
     S          , ZGG,ZREF,ZRMUZ,ZTO1,ZW
     S          , ZRE1,ZRE2,ZTR1,ZTR2     )
C
      DO 323 JL = 1 , KDLON
C
      ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
     S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
     S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
     S               + ZRNEB(JL) * ZRE1(JL)
C
      ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
     S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
C
      ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
     S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)
     S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)
     S             + ZRNEB(JL) * ZRE2(JL)
C
      ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
     S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
     S              * ZREFZ(JL,1,JKM1)))
     S              * ZG(JL) * (1. -ZRNEB(JL))
C
 323  CONTINUE
 324  CONTINUE
C
C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
C               -------------------------------------------------
C
 330  CONTINUE
C
      DO 351 KREF=1,2
C
      JN = JN + 1
C
      DO 331 JL = 1 , KDLON
      ZRJ(JL,JN,KFLEV+1) = 1.
      ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,KREF,KFLEV+1)
 331  CONTINUE
C
      DO 333 JK = 1 , KFLEV
      JKL = KFLEV+1 - JK
      JKLP1 = JKL + 1
      DO 332 JL = 1 , KDLON
      ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,KREF,JKL)
      ZRJ(JL,JN,JKL) = ZRE11
      ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,KREF,JKL)
 332  CONTINUE
 333  CONTINUE
 351  CONTINUE
 361  CONTINUE
C
C
C     ------------------------------------------------------------------
C
C*         4.    INVERT GREY AND CONTINUUM FLUXES
C                --------------------------------
C
 400  CONTINUE
C
C
C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
C                ---------------------------------------------
C
 410  CONTINUE
C
      DO 414 JK = 1 , KFLEV+1
      DO 413 JAJ = 1 , 5 , 2
      JAJP = JAJ + 1
      DO 412 JL = 1 , KDLON
      ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
      ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
      ZRJ(JL,JAJ,JK)= AMAX1( ZRJ(JL,JAJ,JK) , ZEELOG )
      ZRK(JL,JAJ,JK)= AMAX1( ZRK(JL,JAJ,JK) , ZEELOG )
 412  CONTINUE
 413  CONTINUE
 414  CONTINUE
C
      DO 417 JK = 1 , KFLEV+1
      DO 416 JAJ = 2 , 6 , 2
      DO 415 JL = 1 , KDLON
      ZRJ(JL,JAJ,JK)= AMAX1( ZRJ(JL,JAJ,JK) , ZEELOG )
      ZRK(JL,JAJ,JK)= AMAX1( ZRK(JL,JAJ,JK) , ZEELOG )
 415  CONTINUE
 416  CONTINUE
 417  CONTINUE
C
C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
C                 ---------------------------------------------
C
 420  CONTINUE
C
      DO 437 JK = 1 , KFLEV+1
      JKKI = 1
      DO 425 JAJ = 1 , 2
      DO 424 JN = 1 , 2
      JN2J = JN + 2 * JAJ
      JKKP4 = JKKI + 4
C
C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
C                 --------------------------
C
 4210 CONTINUE
C
      DO 4211 JL = 1 , KDLON
      ZW1(JL) = ALOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
     S                   / PAKI(JL,JAJ)
 4211 CONTINUE
C
C*         4.2.2  TRANSMISSION FUNCTION
C                 ---------------------
C
 4220 CONTINUE
C
      CALL SWTT ( KDLON, KNU, JAJ, ZW1, ZR1 )
C
      DO 4221 JL = 1 , KDLON
      ZRL(JL,JKKI) = ZR1(JL)
      ZRUEF(JL,JKKI) = ZW1(JL)
      ZW2(JL) = ALOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
     S                    / PAKI(JL,JAJ)
 4221 CONTINUE
C
      CALL SWTT ( KDLON, KNU, JAJ, ZW2, ZR2 )
C
      DO 423 JL = 1 , KDLON
      ZRL(JL,JKKP4) = ZR2(JL)
      ZRUEF(JL,JKKP4) = ZW2(JL)
 423  CONTINUE
C
      JKKI=JKKI+1
 424  CONTINUE
 425  CONTINUE
C
C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
C                 ------------------------------------------------------
C
 430  CONTINUE
C
      DO 431 JL = 1 , KDLON
      PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
     S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
      PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
     S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
 431  CONTINUE
 437  CONTINUE
C
C
C     ------------------------------------------------------------------
C
C*         5.     INTRODUCTION OF OZONE ABSORPTION
C                 --------------------------------
C
 500  CONTINUE
C
      JABS=3
      DO 504 JK = 1 , KFLEV+1
      DO 501 JL = 1 , KDLON
      ZW1(JL) = PUD(JL,JABS,JK)
 501  CONTINUE
C
      CALL SWTT ( KDLON, KNU, JABS, ZW1, ZR1 )
C
      DO 502 JL = 1 , KDLON
      PFDOWN(JL,JK) = ZR1(JL) * PFDOWN(JL,JK) * sunfr(KNU)
      ZW2(JL) = PUM(JL,JK)
 502  CONTINUE
C
      CALL SWTT ( KDLON, KNU, JABS, ZW2, ZR2 )
C
      DO 503 JL = 1 , KDLON
      PFUP(JL,JK) = ZR2(JL) * PFUP(JL,JK) * sunfr(KNU)
 503  CONTINUE
 504  CONTINUE
C
C     ------------------------------------------------------------------
C
      RETURN
      END