SUBROUTINE SW & &( KIDIA, KFDIA , KLON , KLEV , KAER & &, PSCT , PCARDI, PPSOL , PALBD, PALBP , PWV, PQS & &, PRMU0, PCG , PCLDSW, PDP , POMEGA, POZ, PPMB & &, PTAU , PTAVE , PAER & &, PHEAT, PFDOWN, PFUP & &, PCEAT, PCDOWN, PCUP & &, PFDNN, PFDNV , PFUPN, PFUPV & &, PCDNN, PCDNV , PCUPN, PCUPV & &, PSUDU, PUVDF , PPARF & &) !**** *SW* - COMPUTES THE SHORTWAVE RADIATION FLUXES. ! PURPOSE. ! -------- ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). !** INTERFACE. ! ---------- ! *SW* IS CALLED FROM *RADLSW* ! IMPLICIT ARGUMENTS : ! -------------------- ! ==== INPUTS === ! ==== OUTPUTS === ! METHOD. ! ------- ! 1. COMPUTES ABSORBER AMOUNTS (SWU) ! 2. COMPUTES FLUXES IN U.V./VISIBLE SPECTRAL INTERVAL (SW1S) ! 3. COMPUTES FLUXES IN NEAR-INFRARED SPECTRAL INTERVAL (SWNI) ! EXTERNALS. ! ---------- ! *SWU*, *SW1S*, *SWNI* ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 89-07-14 ! 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo ! 95-12-07 J.-J. MORCRETTE Near-Infrared in nsw-1 Intervals ! 990128 JJMorcrette sunshine duration ! 99-05-25 JJMorcrette Revised aerosols ! 00-12-18 JJMorcrette 6 spectral intervals ! ------------------------------------------------------------------ #include "tsmbkind.h" USE YOERAD , ONLY : NSW USE YOERDU , ONLY : RCDAY IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER_M :: KAER INTEGER_M :: KFDIA INTEGER_M :: KIDIA INTEGER_M :: KLEV INTEGER_M :: KLON ! DUMMY REAL SCALARS REAL_B :: PCARDI REAL_B :: PSCT ! ------------------------------------------------------------------ !* 0.1 ARGUMENTS ! --------- REAL_B :: PPSOL(KLON), PAER(KLON,6,KLEV),PRMU0(KLON)& &, PWV(KLON,KLEV),PQS(KLON,KLEV) REAL_B :: PALBD(KLON,NSW) , PALBP(KLON,NSW)& &, PCG(KLON,NSW,KLEV) , PCLDSW(KLON,KLEV)& &, PDP(KLON,KLEV) & &, POMEGA(KLON,NSW,KLEV), POZ(KLON,KLEV)& &, PPMB(KLON,KLEV+1)& &, PTAU(KLON,NSW,KLEV) , PTAVE(KLON,KLEV) REAL_B :: PHEAT(KLON,KLEV), PFDOWN(KLON,KLEV+1), PFUP(KLON,KLEV+1),& &PFUPV(KLON), PFUPN(KLON), PFDNV(KLON), PFDNN(KLON)& &, PCEAT(KLON,KLEV), PCDOWN(KLON,KLEV+1), PCUP(KLON,KLEV+1)& &, PCUPV(KLON), PCUPN(KLON), PCDNV(KLON), PCDNN(KLON)& &, PSUDU(KLON), PUVDF(KLON), PPARF(KLON) ! ------------------------------------------------------------------ !* 0.2 LOCAL ARRAYS ! ------------ REAL_B :: ZAKI(KLON,2,NSW)& &, ZCLD(KLON,KLEV) , ZCLEAR(KLON) & &, ZDSIG(KLON,KLEV) , ZFACT(KLON)& &, ZFD(KLON,KLEV+1) , ZCD(KLON,KLEV+1)& &, ZCDOWN(KLON,KLEV+1), ZCDNIR(KLON,KLEV+1), ZCDUVS(KLON,KLEV+1)& &, ZFDOWN(KLON,KLEV+1), ZFDNIR(KLON,KLEV+1), ZFDUVS(KLON,KLEV+1)& &, ZFU(KLON,KLEV+1) , ZCU(KLON,KLEV+1)& &, ZCUP(KLON,KLEV+1) , ZCUNIR(KLON,KLEV+1), ZCUUVS(KLON,KLEV+1)& &, ZFUP(KLON,KLEV+1) , ZFUNIR(KLON,KLEV+1), ZFUUVS(KLON,KLEV+1)& &, ZRMU(KLON) , ZSEC(KLON) & &, ZSUDU1(KLON) , ZSUDU2(KLON) & &, ZSUDU1T(KLON) , ZSUDU2T(KLON) & &, ZUD(KLON,5,KLEV+1) ! LOCAL INTEGER SCALARS INTEGER_M :: INU, JK, JKL, JL, JNU, INUVS, INUIR ! LOCAL REAL SCALARS REAL_B :: ZDCNET, ZDFNET ! ------------------------------------------------------------------ !* 1. ABSORBER AMOUNTS AND OTHER USEFUL QUANTITIES ! -------------------------------------------- CALL SWU ( KIDIA,KFDIA ,KLON ,KLEV & &, PSCT ,PCARDI,PCLDSW,PPMB ,PPSOL & &, PRMU0,PTAVE ,PWV & &, ZAKI ,ZCLD ,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD ) !print *,'After SWU' ! ------------------------------------------------------------------ !* 2. INTERVAL (0.185/0.25-0.68 MICRON): U.V. AND VISIBLE ! --------------------------------------------------- IF (NSW.LE.4) THEN INUVS=1 INUIR=2 ELSE IF (NSW.EQ.6) THEN INUVS=1 INUIR=4 END IF DO JK = 1 , KLEV+1 DO JL = KIDIA,KFDIA ZFD(JL,JK) =_ZERO_ ZFU(JL,JK) =_ZERO_ ZCD(JL,JK) =_ZERO_ ZCU(JL,JK) =_ZERO_ ZSUDU1T(JL)=_ZERO_ PUVDF(JL) =_ZERO_ PPARF(JL) =_ZERO_ ENDDO ENDDO DO JNU = INUVS , INUIR-1 CALL SW1S & &( KIDIA , KFDIA, KLON , KLEV , KAER , JNU & &, PAER , PALBD , PALBP, PCG , ZCLD , ZCLEAR & &, ZDSIG, POMEGA, POZ , ZRMU , ZSEC , PTAU , ZUD & &, ZFDUVS,ZFUUVS, ZCDUVS,ZCUUVS, ZSUDU1 & &) DO JK = 1 , KLEV+1 DO JL = KIDIA,KFDIA ZFD(JL,JK)=ZFD(JL,JK)+ZFDUVS(JL,JK) ZFU(JL,JK)=ZFU(JL,JK)+ZFUUVS(JL,JK) ZCD(JL,JK)=ZCD(JL,JK)+ZCDUVS(JL,JK) ZCU(JL,JK)=ZCU(JL,JK)+ZCUUVS(JL,JK) ENDDO ENDDO DO JL = KIDIA,KFDIA ZSUDU1T(JL)=ZSUDU1T(JL)+ZSUDU1(JL) ENDDO IF (NSW.EQ.6) THEN IF (JNU.LT.INUIR-1) THEN DO JL=KIDIA,KFDIA PUVDF(JL)=PUVDF(JL)+ZFDUVS(JL,1) END DO ELSE DO JL=KIDIA,KFDIA PPARF(JL)=PPARF(JL)+ZFDUVS(JL,1) END DO END IF END IF ENDDO !print *,'After SW1S' ! ------------------------------------------------------------------ !* 3. INTERVAL (0.68-4.00 MICRON): NEAR-INFRARED ! ------------------------------------------ DO JK = 1 , KLEV+1 DO JL = KIDIA,KFDIA ZFDOWN(JL,JK)=_ZERO_ ZFUP (JL,JK)=_ZERO_ ZCDOWN(JL,JK)=_ZERO_ ZCUP (JL,JK)=_ZERO_ ZSUDU2T(JL) =_ZERO_ ENDDO ENDDO DO JNU = INUIR , NSW CALL SWNI & &( KIDIA ,KFDIA , KLON , KLEV , KAER , JNU & &, PAER ,ZAKI , PALBD, PALBP, PCG , ZCLD, ZCLEAR & &, ZDSIG ,POMEGA, POZ , ZRMU , ZSEC , PTAU, ZUD & &, PWV ,PQS & &, ZFDNIR,ZFUNIR,ZCDNIR,ZCUNIR,ZSUDU2 & &) DO JK = 1 , KLEV+1 DO JL = KIDIA,KFDIA ZFDOWN(JL,JK)=ZFDOWN(JL,JK)+ZFDNIR(JL,JK) ZFUP (JL,JK)=ZFUP (JL,JK)+ZFUNIR(JL,JK) ZCDOWN(JL,JK)=ZCDOWN(JL,JK)+ZCDNIR(JL,JK) ZCUP (JL,JK)=ZCUP (JL,JK)+ZCUNIR(JL,JK) ENDDO ENDDO DO JL = KIDIA,KFDIA ZSUDU2T(JL)=ZSUDU2T(JL)+ZSUDU2(JL) ENDDO ENDDO ! ------------------------------------------------------------------ !* 4. FILL THE DIAGNOSTIC ARRAYS ! -------------------------- DO JL = KIDIA,KFDIA PFDNN(JL)=ZFDOWN(JL,1)*ZFACT(JL) PFDNV(JL)=ZFD(JL,1)*ZFACT(JL) PFUPN(JL)=ZFUP(JL,KLEV+1)*ZFACT(JL) PFUPV(JL)=ZFU(JL,KLEV+1)*ZFACT(JL) PCDNN(JL)=ZCDOWN(JL,1)*ZFACT(JL) PCDNV(JL)=ZCD(JL,1)*ZFACT(JL) PCUPN(JL)=ZCUP(JL,KLEV+1)*ZFACT(JL) PCUPV(JL)=ZCU(JL,KLEV+1)*ZFACT(JL) PSUDU(JL)=(ZSUDU1T(JL)+ZSUDU2T(JL))*ZFACT(JL) PUVDF(JL)=PUVDF(JL)*ZFACT(JL) PPARF(JL)=PPARF(JL)*ZFACT(JL) ENDDO DO JK = 1 , KLEV+1 DO JL = KIDIA,KFDIA PFUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) PFDOWN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) PCUP(JL,JK) = (ZCUP(JL,JK) + ZCU(JL,JK)) * ZFACT(JL) PCDOWN(JL,JK) = (ZCDOWN(JL,JK) + ZCD(JL,JK)) * ZFACT(JL) ENDDO ENDDO DO JKL = 1 , KLEV JK = KLEV+1 - JKL DO JL = KIDIA,KFDIA ZDFNET = PFUP(JL,JK+1) - PFDOWN(JL,JK+1)-PFUP(JL,JK ) + PFDOWN(JL,JK ) PHEAT(JL,JK) = RCDAY * ZDFNET / PDP(JL,JKL) ZDCNET = PCUP(JL,JK+1) - PCDOWN(JL,JK+1)-PCUP(JL,JK ) + PCDOWN(JL,JK ) PCEAT(JL,JK) = RCDAY * ZDCNET / PDP(JL,JKL) ENDDO ENDDO ! ------------------------------------------------------------------ RETURN END SUBROUTINE SW