*=*=*=*= SW.html =*=*=*=*
SUBROUTINE SW

SUBROUTINE SW


      SUBROUTINE SW ( KDLON, KFLEV, KAER
     S              , PSCT, PCARDI, PPSOL, PALBS, PWV, PRMU0, PCG
     S              , PCLDSW, PDP, POMEGA, POZ, PPMB, PTAU, PTAVE, PAER
     S              , PHEAT, PFDOWN, PFUP, PFDNN, PFDNV, PFUPN, PFUPV
     S    ,PFRACT)
      IMPLICIT LOGICAL (L)
C
#include "dimensions.h"
#include "dimphys.h"
#include "dimradmars.h"
C
C**** *SW* - COMPUTES THE SHORTWAVE RADIATION FLUXES.
C
C     PURPOSE.
C     --------
C
C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
C
C**   INTERFACE.
C     ----------
C     SUBROUTINE SW ( KDLON, KFLEV, KAER
C    S              , PSCT, PCARDI, PPSOL, PALBS, PWV, PRMU0, PCG
C    S              , PCLDSW, PDP, POMEGA, POZ, PPMB, PTAU, PTAVE, PAER
C    S              , PHEAT, PFDOWN, PFUP, PFDNN, PFDNV, PFUPN, PFUPV  )
C
C          *SW* IS CALLED FROM *RADITE*
C
C
C        IMPLICIT ARGUMENTS :
C        --------------------
C
C     ==== INPUTS ===
C     ==== OUTPUTS ===
C
C     METHOD.
C     -------
C
C          1. COMPUTES ABSORBER AMOUNTS
C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL
C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL
C
C     EXTERNALS.
C     ----------
C
C          *SWU*, *SW1S*, *SW2S*
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 PPSOL(NDLO2), PAER(NDLO2,KFLEV,5),PRMU0(NDLO2)
     S    ,PWV(NDLO2,KFLEV)
C
      REAL PALBS(NDLO2,2), PCG(NDLO2,2,KFLEV), PCLDSW(NDLO2,KFLEV),
     S     PDP(NDLO2,KFLEV), POMEGA(NDLO2,2,KFLEV), POZ(NDLO2,KFLEV),
     S     PPMB(NDLO2,KFLEV+1), PTAU(NDLO2,2,KFLEV), PTAVE(NDLO2,KFLEV)
C
      REAL PHEAT(NDLO2,KFLEV),PFDOWN(NDLO2,KFLEV+1),PFUP(NDLO2,KFLEV+1),
     S     PFUPV(NDLO2),PFUPN(NDLO2),PFDNV(NDLO2),PFDNN(NDLO2)
C
      REAL PFRACT(NDLO2)
C     ------------------------------------------------------------------
C
C*       0.2   LOCAL ARRAYS
C              ------------
C
      REAL ZAKI(NDLON,2), ZDSIG(NDLON,NFLEV), ZFACT(NDLON)
     S  ,  ZFD(NDLON,NFLEV+1), ZFDOWN(NDLON,NFLEV+1)
     S  ,  ZFU(NDLON,NFLEV+1), ZFUP(NDLON,NFLEV+1)
     S  ,  ZHESW1(NDLON), ZHESW2(NDLON)
     S  ,  ZRMU(NDLON), ZSEC(NDLON)
     S  ,  ZUD(NDLON,3,NFLEV+1), ZUM(NDLON,NFLEV+1)
C
C     ------------------------------------------------------------------
C
C*         1.     ABSORBER AMOUNTS AND OTHER USEFUL QUANTITIES
C                 --------------------------------------------
C
 100  CONTINUE
C

      CALL SWU (      KDLON, KFLEV, KAER
     S              , PSCT,PCARDI,POZ,PPMB,PPSOL,PRMU0,PTAVE,PWV
     S              , ZAKI,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD,ZUM
     S    ,PFRACT)
C
C
C     ------------------------------------------------------------------
C
C*         2.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
C                 ----------------------- ------------------
C
 200  CONTINUE
C
      INU = 1
C
      CALL SW1S ( KDLON, KFLEV, KAER, INU
     S  ,  PAER,PALBS,PCG,PCLDSW,ZDSIG,POMEGA,ZRMU,ZSEC,PTAU
     S  ,  ZUD,ZUM
     S  ,  ZFD,ZFU                                                 )
C
C
C     ------------------------------------------------------------------
C
C*         3.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
C                 -------------------------------------------
C
 300  CONTINUE
C
      INU = 2
C
      CALL SW1S ( KDLON, KFLEV, KAER, INU
     S  ,  PAER,PALBS,PCG,PCLDSW,ZDSIG,POMEGA,ZRMU,ZSEC,PTAU
     S  ,  ZUD,ZUM
     S  ,  ZFDOWN,ZFUP                                                )
C
C     CALL SW2S ( KDLON, KFLEV, KAER, INU
C    S  ,  PAER,ZAKI,PALBS,PCG,PCLDSW,ZDSIG,POMEGA,ZRMU,ZSEC,PTAU
C    S  ,  ZUD,ZUM
C    S  ,  ZFDOWN,ZFUP                                                )
C
C
C     ------------------------------------------------------------------
C
C*         4.     FILL THE DIAGNOSTIC ARRAYS
C                 --------------------------
C
 400  CONTINUE
C
      DO 401 JL = 1 , KDLON
      PFDNN(JL)=ZFDOWN(JL,1)*ZFACT(JL)
      PFDNV(JL)=ZFD(JL,1)*ZFACT(JL)
      PFUPN(JL)=ZFUP(JL,KFLEV+1)*ZFACT(JL)
      PFUPV(JL)=ZFU(JL,KFLEV+1)*ZFACT(JL)
 401  CONTINUE
C
C     print*,'zfact',zfact(1)
      DO 403 JK = 1 , KFLEV+1
      DO 402 JL = 1 , KDLON
      PFUP(JL,JK)   = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
      PFDOWN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
 402  CONTINUE
 403  CONTINUE
C
      DO 405 JK = 1 , KFLEV
      DO 404 JL = 1 , KDLON
      ZDFNET = PFUP (JL,JK  ) - PFDOWN(JL,JK  )
     S        -PFUP (JL,JK+1) + PFDOWN(JL,JK+1)
      PHEAT(JL,JK) = CDAY * ZDFNET / PDP(JL,JK)
      ZDFNET = ZFUP (JL,JK  ) - ZFDOWN(JL,JK  )
     S        -ZFUP (JL,JK+1) + ZFDOWN(JL,JK+1)
      ZHESW2(JL)   = CDAY * ZDFNET / PDP(JL,JK) * ZFACT(JL)
      ZDFNET = ZFU  (JL,JK  ) - ZFD   (JL,JK  )
     S        -ZFU  (JL,JK+1) + ZFD   (JL,JK+1)
      ZHESW1(JL)   = CDAY * ZDFNET / PDP(JL,JK) * ZFACT(JL)
 404  CONTINUE
C     PRINT 9499,JK,(PHEAT(JL,JK),ZHESW1(JL),ZHESW2(JL),JL=1,KDLON,2)
 405  CONTINUE
C
C
C     ------------------------------------------------------------------
C
      RETURN
 9499 FORMAT (1X,I3,3(2X,3F10.3))
      END