*=*=*=*= SWR.html =*=*=*=*
SUBROUTINE SWR

SUBROUTINE SWR


      SUBROUTINE SWR ( KDLON, KFLEV, KAER, KNU
     S  , PAER, PALBS, PCG, PCLDSW, PDSIG, POMEGA, PRAYL, PSEC, PTAU
     S  , PCGAZ, PPIZAZ, PRAY1, PRAY2, PREFZ, PRJ, PRK, PRMUE
     S  , PTAUAZ, PTRA1, PTRA2 )
      IMPLICIT LOGICAL (L)
C
#include "dimensions.h"
#include "dimphys.h"
#include "dimradmars.h"
C
C**** *SWR* - CONTINUUM SCATTERING COMPUTATIONS
C
C     PURPOSE.
C     --------
C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
C     CONTINUUM SCATTERING
C
C**   INTERFACE.
C     ----------
C     SUBROUTINE SWR ( KDLON, KFLEV, KAER, KNU
C    S  , PAER, PALBS, PCG, PCLDSW, PDSIG, POMEGA, PRAYL, PSEC, PTAU
C    S  , PCGAZ, PPIZAZ, PRAY1, PRAY2, PREFZ, PRJ, PRK, PRMUE
C    S  , PTAUAZ, PTRA1, PTRA2 )
C
C          *SWR* IS CALLED EITHER FROM *SW1S*
C                              OR FROM *SW2S*
C
C        IMPLICIT ARGUMENTS :
C        --------------------
C
C     ==== INPUTS ===
C     ==== OUTPUTS ===
C
C     METHOD.
C     -------
C
C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
C
C     EXTERNALS.
C     ----------
C
C          *DEDD*
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
#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), PALBS(NDLO2,2), PCG(NDLO2,2,KFLEV)
     S  ,  PCLDSW(NDLO2,KFLEV), PDSIG(NDLO2,KFLEV)
     S  ,  POMEGA(NDLO2,2,KFLEV), PRAYL(NDLO2)
     S  ,  PSEC(NDLO2), PTAU(NDLO2,2,KFLEV)
C
      REAL PRAY1(NDLO2,KFLEV+1), PRAY2(NDLO2,KFLEV+1)
     S  ,  PREFZ(NDLO2,2,KFLEV+1), PRJ(NDLO2,6,KFLEV+1)
     S  ,  PRK(NDLO2,6,KFLEV+1), PRMUE(NDLO2,KFLEV+1)
     S  ,  PCGAZ(NDLO2,KFLEV),PPIZAZ(NDLO2,KFLEV),PTAUAZ(NDLO2,KFLEV)
     S  ,  PTRA1(NDLO2,KFLEV+1), PTRA2(NDLO2,KFLEV+1)
C
C     ------------------------------------------------------------------
C
C*       0.2   LOCAL ARRAYS
C              ------------
C
      REAL ZC1I(NDLON,NFLEV+1), ZGG(NDLON), ZREF(NDLON)
     S  ,  ZRE1(NDLON), ZRE2(NDLON)
     S  ,  ZRMUZ(NDLON), ZRNEB(NDLON), ZR21(NDLON), ZR22(NDLON)
     S  ,  ZR23(NDLON),  ZSS1(NDLON), ZTO1(NDLON), ZTR(NDLON,2,NFLEV+1)
     S  ,  ZTR1(NDLON), ZTR2(NDLON), ZW(NDLON)
C
C     ------------------------------------------------------------------
C
C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
C                --------------------------------------------
C
 100  CONTINUE
C
      DO 103 JK = 1 , KFLEV+1
      DO 102 JA = 1 , 6
      DO 101 JL = 1 , KDLON
      PRJ(JL,JA,JK) = 0.
      PRK(JL,JA,JK) = 0.
 101  CONTINUE
 102  CONTINUE
 103  CONTINUE
C
      DO 108 JK = 1 , KFLEV
      DO 104 JL = 1 , KDLON
      PCGAZ(JL,JK) = 0.
      PPIZAZ(JL,JK) =  0.
      PTAUAZ(JL,JK) = 0.
 104  CONTINUE
      DO 106 JAE=1,5
      DO 105 JL = 1 , KDLON
      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
     S        * TAUA(KNU,JAE)*PIZA(KNU,JAE)
      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
     S        * TAUA(KNU,JAE)*PIZA(KNU,JAE)*CGA(KNU,JAE)
 105  CONTINUE
 106  CONTINUE
C
      DO 107 JL = 1 , KDLON


c!-*-
c      if ((JK.eq.25).and.(JL.eq.200)) then
c      print *,'sol 1',PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK)
c    &               ,JL,JK
c      do JAE=1,5
c      print *,'jae',jae,PAER(JL,JK,JAE),TAUA(KNU,JAE),PIZA(KNU,JAE)
c    &                 ,CGA(KNU,JAE)
c      enddo
c      endif
c!-*-


      PCGAZ(JL,JK) = CVMGT( 0., PCGAZ(JL,JK) / PPIZAZ(JL,JK),
     S                     (KAER.EQ.0).or.
     S                     (PPIZAZ(JL,JK).EQ.0) )
      PPIZAZ(JL,JK) = CVMGT( 1., PPIZAZ(JL,JK) / PTAUAZ(JL,JK),
     S                     (KAER.EQ.0).or.
     S                     (PTAUAZ(JL,JK).EQ.0) )
      PTAUAZ(JL,JK) = CVMGT( 0., PTAUAZ(JL,JK),
     S                     (KAER.EQ.0) )


c!-*-
c      if ((JK.eq.25).and.(JL.eq.200)) then
c      print *,'sol 2',PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK)
c    &               ,JL,JK
c      endif
c!-*-


      ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
      ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
      ZGAR = PCGAZ(JL,JK)
      ZFF = ZGAR * ZGAR
      PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
      PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
      PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
     S                    / (1. - PPIZAZ(JL,JK) * ZFF)


c!-*-
c      if ((JK.eq.25).and.(JL.eq.200)) then
c      print *,'sol 3',PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK)
c    &               ,JL,JK
c      endif
c!-*-


 107  CONTINUE
C
      IF (NIMP.LT.2) THEN
      print*,'SWR   TAU  G  PI '
      PRINT 9401,JK,PTAUAZ(JLIMPRAD,JK),PCGAZ(JLIMPRAD,JK)
     ,   ,PPIZAZ(JLIMPRAD,JK)
      END IF
C
 108  CONTINUE
C
C
C     ------------------------------------------------------------------
C
C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
C                ----------------------------------------------
C
 200  CONTINUE
C
      DO 201 JL = 1 , KDLON
      ZR23(JL) = 0.
      ZC1I(JL,KFLEV+1) = 0.
 201  CONTINUE
C
      DO 203 JK = 1 , KFLEV
      JKL = KFLEV+1 - JK
      JKLP1 = JKL + 1
      DO 202 JL = 1 , KDLON
      ZFACOA = 1.-PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
     S                                 * PCG(JL,KNU,JKL)
      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
      ZR21(JL) = EXP(-ZCORAE   )
      ZR22(JL) = EXP(-ZCORCD   )
      ZSS1(JL) = PCLDSW(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
     S               + (1.0-PCLDSW(JL,JKL))*(1.0-ZR21(JL))
      ZC1I(JL,JKL) = 1.0-(1.0-ZSS1(JL))*(1.0-ZC1I(JL,JKLP1))
 202  CONTINUE
C
      IF (NIMP.LT.2) THEN
      print*,'SWR coeffs diff'
      PRINT 9401,JK,ZR21(JLIMPRAD),ZR22(JLIMPRAD),ZSS1(JLIMPRAD)
     ,   ,ZC1I(JLIMPRAD,JKL)
      END IF
C
 203  CONTINUE

C
C
C     ------------------------------------------------------------------
C
C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
C                -----------------------------------------------
C
 300  CONTINUE
C
      DO 301 JL = 1 , KDLON
      PRAY1(JL,KFLEV+1) = 0.
      PRAY2(JL,KFLEV+1) = 0.
      PREFZ(JL,2,1) = PALBS(JL,KNU)
      PREFZ(JL,1,1) = PALBS(JL,KNU)
      PTRA1(JL,KFLEV+1) = 1.
      PTRA2(JL,KFLEV+1) = 1.
 301  CONTINUE
C
      DO 346 JK = 2 , KFLEV+1
      JKM1 = JK-1
      DO 342 JL = 1 , KDLON
      ZRNEB(JL)= PCLDSW(JL,JKM1)
      ZRE1(JL)=0.
      ZTR1(JL)=0.
      ZRE2(JL)=0.
      ZTR2(JL)=0.
C
C
C     ------------------------------------------------------------------
C
C*         3.1  EQUIVALENT ZENITH ANGLE
C               -----------------------
C
 310  CONTINUE
C
      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
     S            + ZC1I(JL,JK) * 1.66
      PRMUE(JL,JK) = 1./ZMUE
C
C
C     ------------------------------------------------------------------
C
C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
C               ----------------------------------------------------
C
 320  CONTINUE
C
      ZGAP = PCGAZ(JL,JKM1)
      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
      ZWW = PPIZAZ(JL,JKM1)
      ZTO = PTAUAZ(JL,JKM1)
      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
      PTRA1(JL,JKM1) = 1. / ZDEN
C
      ZMU1 = 0.5
      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
      PTRA2(JL,JKM1) = 1. / ZDEN1
C
C
C     ------------------------------------------------------------------
C
C*         3.3  EFFECT OF CLOUD LAYER
C               ---------------------
C
 330  CONTINUE
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         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
     S              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
      ZW(JL) = ZR21(JL) / ZTO1(JL)
      ZREF(JL) = PREFZ(JL,1,JKM1)
      ZRMUZ(JL) = PRMUE(JL,JK)
 342  CONTINUE
C
         CALL DEDD ( KDLON
     S             , ZGG,ZREF,ZRMUZ,ZTO1,ZW
     S             , ZRE1,ZRE2,ZTR1,ZTR2     )
C
      DO 345 JL = 1 , KDLON
C
      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
     S               * PTRA2(JL,JKM1)
     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
     S               + ZRNEB(JL) * ZRE2(JL)
C
      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
     S               * (1.-ZRNEB(JL))
C
      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
     S               * PTRA2(JL,JKM1) )
     S               + ZRNEB(JL) * ZRE1(JL)
C
      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
     S               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
C
 345  CONTINUE
      if(nimp.le.4) then
         jl=jlimprad
         print*,'diags en sorties de dedd'
         print*,'ZGG,ZREF,ZRMUZ,ZTO1,ZW,ZRE1,ZRE2,ZTR1,ZTR2,ZRNEB'
         print*,ZGG(jl),ZREF(jl),ZRMUZ(jl),ZTO1(jl),ZW(jl)
     ,   ,ZRE1(JL),ZRE2(JL),ZTR1(JL),ZTR2(JL),ZRNEB(JL)
       endif
 346  CONTINUE
C
C
C     ------------------------------------------------------------------
C
C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
C                 -------------------------------------------------
C
 350  CONTINUE
C
      IF (KNU.EQ.1) THEN
      JAJ = 2
      DO 351 JL = 1 , KDLON
      PRJ(JL,JAJ,KFLEV+1) = 1.
      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
 351  CONTINUE
C
      DO 353 JK = 1 , KFLEV
      JKL = KFLEV+1 - JK
      JKLP1 = JKL + 1
      DO 352 JL = 1 , KDLON
      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
      PRJ(JL,JAJ,JKL) = ZRE11
      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
 352  CONTINUE
 353  CONTINUE
 354  CONTINUE
C
      ELSE
C
      DO 358 JAJ = 1 , 2
      DO 355 JL = 1 , KDLON
      PRJ(JL,JAJ,KFLEV+1) = 1.
      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
 355  CONTINUE
C
      DO 357 JK = 1 , KFLEV
      JKL = KFLEV+1 - JK
      JKLP1 = JKL + 1
      DO 356 JL = 1 , KDLON
      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
      PRJ(JL,JAJ,JKL) = ZRE11
      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
 356  CONTINUE
 357  CONTINUE
 358  CONTINUE
C
      END IF
C
      IF (NIMP.EQ.0) THEN
         print*,'coefs pour l inversion de la diffusion SWR'
         JL=JLIMPRAD
         DO 401 JK = 1 , KFLEV+1
         PRINT 9401,JK,PRAY1(JL,JK),PTRA1(JL,JK)
     S            ,PRAY2(JL,JK),PTRA2(JL,JK)
     S            ,PREFZ(JL,1,JK),ZTR(JL,1,JK)
     S            ,PREFZ(JL,2,JK),ZTR(JL,2,JK)
 401     CONTINUE
C
         DO 402 JK = 1 , KFLEV
         PRINT 9402,JK,PRMUE(JL,JK),PCGAZ(JL,JK)
     S         ,PPIZAZ(JL,JK),PTAUAZ(JL,JK)
 402     CONTINUE
C
         DO 403 JK = 1 , KFLEV+1
         PRINT 9403,JK,(PRJ(JL,JA,JK),PRK(JL,JA,JK),JA=1,2)
 403     CONTINUE
      END IF
C
C     ------------------------------------------------------------------
C
      RETURN
 899  FORMAT(1X,' SWR LOOP ',I4,' EXECUTED')
 9401 FORMAT (1X,I3,8E12.5)
 9402 FORMAT (1X,I3,4E15.6)
 9403 FORMAT (1X,I3,4E16.8)
      END