*=*=*=*= LWVB.html =*=*=*=*
SUBROUTINE LWVB ( KDLON,KFLEV,KUAER,KTRAER S , pgab,pgbb S , PABCUCO2,PABCUAER,PADJD,PADJU,PBINT,PBSUI,PBSUR,PBTOP S , PDISD,PDISU,PEMIS S , PBHDD,PBSDD S , PCTS,PHFG,PFLUC ) IMPLICIT LOGICAL (L) C #include "dimensions.h" #include "dimphys.h" #include "dimradmars.h" C C**** *LWVB* - L.W., VERTICAL INTEGRATION, EXCHANGE WITH BOUNDARIES C C PURPOSE. C -------- C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL C INTEGRATION C C** INTERFACE. C ---------- C SUBROUTINE LWVB ( KDLON,KFLEV,KUAER,KTRAER C S , KXTSU,KXTTP C S , PABCUCO2,PABCUAER,PADJD,PADJU,PBINT,PBSUI,PBSUR,PBTOP C S , PDISD,PDISU,PEMIS C S , PBHDD,PBSDD C S , PCTS,PHFG,PFLUC ) C C EXPLICIT ARGUMENTS : C -------------------- C ==== INPUTS === C KX... (KDLON,... ; TEMPERATURE INDICES C PABCUCO2 : (KDLON,NUACO2,3*KFLEV+1); ABSORBER AMOUNTS (CO2) C PABCUAER : (KDLON,NIR,3*KFLEV+1); ABSORBER AMOUNTS (AEROSOLS) C PADJ.. : (KDLON,KFLEV+1) ; CONTRIBUTION BY ADJACENT LAYERS C PBINT : (KDLON,KFLEV+1) ; HALF-LEVEL PLANCK FUNCTIONS C PBSUI : (KDLON) ; SURFACE PLANCK FUNCTION C PBSUR : (KDLON,nir) ; SURFACE SPECTRAL PLANCK FUNCTION C PBTOP : (KDLON,nir) ; T.O.A. SPECTRAL PLANCK FUNCTION C PDIS.. : (KDLON,KFLEV+1) ; CONTRIBUTION BY DISTANT LAYERS C PEMIS : (KDLON) ; SURFACE EMISSIVITY C PBHDD : (KDLON,KFLEV*2+1) ; PLANCK FUNCTION AT TOP OF HALF LAYERS (diffusio C PBSDD : (KDLON) ; PLANCK FUNCTION AT GROUND (diffusion) C ==== OUTPUTS === C PCTS : (KDLON,KFLEV) ; COOLING-TO-SPACE TERM C PHFG : (KDLON,KFLEV) ; HEATING-FROM-GROUND TERM C IF KMODE = 0, 1, 2 C PFLUC(KDLON,2,KFLEV) ; RADIATIVE FLUXES CLEAR-SKY: C 1 ==> UPWARD FLUX TOTAL C C IMPLICIT ARGUMENTS : NONE C -------------------- C C METHOD. C ------- C C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE C ATMOSPHERE C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES C C EXTERNALS. C ---------- C C *LWTT* C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "IN CORE MODEL" C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C----------------------------------------------------------------------- C c! modif diffusion c! on ne prend en compte que les deux bandes du CO2. c! le probleme devient betement d'enlever les Planck cumules hors c! CO2 aux Planck total pour retrouver les Planck du CO2 seul. 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 pgab(NDLO2*2*3,2),pgbb(NDLO2*2*3,2) REAL PABCUCO2(NDLO2,NUACO2,3*KFLEV+1) REAL PABCUAER(NDLO2,nir,3*KFLEV+1) S , PADJD(NDLO2,KFLEV+1), PADJU(NDLO2,KFLEV+1) S , PBINT(NDLO2,KFLEV+1) S , PBSUR(NDLO2,nir), PBSUI(NDLO2), PBTOP(NDLO2,nir) S , PDISD(NDLO2,KFLEV+1), PDISU(NDLO2,KFLEV+1) S , PEMIS(NDLO2) S , PBHDD(NDLO2,KFLEV*2+1),PBSDD(NDLO2) C, PTAVE(NDLO2,KFLEV) C REAL PFLUC(NDLO2,2,KFLEV+1) S , PCTS(NDLO2,KFLEV),PHFG(NDLO2,KFLEV) C C------------------------------------------------------------------------- C C* 0.2 LOCAL ARRAYS C ------------ C REAL ZBGND(NDLON), ZFD(NDLON), ZFDN(NDLON,NFLEV+1) S , ZFU(NDLON), ZFUP(NDLON,NFLEV+1) S , ZTT(NDLON,NTRA), ZTT1(NDLON,NTRA), ZTT2(NDLON,NTRA) S , ZUU(NDLON,NUA) C C----------------------------------------------------------------------- C C* 1. INITIALIZATION C -------------- C 100 CONTINUE C C C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS C --------------------------------- C 120 CONTINUE C DO 122 JA = 1 , NTRA DO 121 JL = 1 , KDLON ZTT (JL,JA) = 1.0 ZTT1(JL,JA) = 1.0 ZTT2(JL,JA) = 1.0 121 CONTINUE 122 CONTINUE C DO 124 JA = 1 , NUA DO 123 JL = 1 , KDLON ZUU(JL,JA) = 0. 123 CONTINUE 124 CONTINUE C C ------------------------------------------------------------------ C C* 2. VERTICAL INTEGRATION C -------------------- C 200 CONTINUE C IND1=0 IND3=0 IND4=1 IND2=1 C C C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE C ----------------------------------- C 230 CONTINUE C DO 235 JK = 1 , KFLEV+1 KN=(JK-1)*NG1P1+1 C DO 232 JA = 1 , 4 DO 231 JL = 1 , KDLON ZUU(JL,JA) = PABCUCO2(JL,JA,KN) 231 CONTINUE 232 CONTINUE DO ja=3,4 DO jl=1,kdlon ztt(jl,ja)=pabcuaer(jl,ja-2,kn) ENDDO ENDDO C CALL LWTT(KDLON,pgab(1,2),pgbb(1,2),ZUU,ZTT) C DO 234 JL = 1 , KDLON ZCNTOP= 1 PBTOP(JL,1)*ZTT(JL,1)*ZTT(JL,3) 2 + PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,4) JKDD=2*(KFLEV-JK+1)+1 c! ZFD(JL)=ZCNTOP-(PBINT(JL,JK)-PBHDD(JL,JKDD)) &-PDISD(JL,JK)-PADJD(JL,JK) c! ZFDN(JL,JK)=ZFD(JL) PFLUC(JL,2,JK)=ZFD(JL) 234 CONTINUE C 235 CONTINUE C C* 2.4 COOLING-TO-SPACE OF UPPERMOST LAYER C ----------------------------------- C 240 CONTINUE C KTOPM = (KFLEV-1)*NG1P1 + 1 C DO 243 JA = 1 , 4 DO 242 JL = 1 , KDLON ZUU(JL,JA) = PABCUCO2(JL,JA,KTOPM) 242 CONTINUE 243 CONTINUE DO ja=3,4 DO jl=1,kdlon ztt(jl,ja)=pabcuaer(jl,ja-2,ktopm) ENDDO ENDDO C CALL LWTT(KDLON,pgab(1,2),pgbb(1,2),ZUU,ZTT) C DO 244 JL = 1 , KDLON ZCTSTOP = 1 PBTOP(JL,1)*(1.-ZTT(JL,1)*ZTT(JL,3)) 2 + PBTOP(JL,2)*(1.-ZTT(JL,2)*ZTT(JL,4)) PCTS(JL,KFLEV) = ZCTSTOP 244 CONTINUE C C* 2.5 EXCHANGE WITH LOWER LIMIT C ------------------------- C 250 CONTINUE C DO 255 JK = 1 , KFLEV+1 KN=(JK-1)*NG1P1+1 C DO 251 JL = 1 , KDLON JKDD=2*KFLEV+1 c! ZBGND(JL)=(PBSUI(JL)-PBSDD(JL))*PEMIS(JL)-(1.-PEMIS(JL)) S *PFLUC(JL,2,1)-(PBINT(JL,1)-PBHDD(JL,JKDD)) c! 251 CONTINUE C DO 253 JA = 1 , 4 DO 252 JL = 1 , KDLON ZUU(JL,JA) = PABCUCO2(JL,JA,1) - PABCUCO2(JL,JA,KN) 252 CONTINUE 253 CONTINUE DO ja=3,4 DO jl=1,kdlon ztt(jl,ja)=pabcuaer(jl,ja-2,1)/pabcuaer(jl,ja-2,kn) ENDDO ENDDO C CALL LWTT (KDLON,pgab(1,1),pgbb(1,1),ZUU,ZTT) C DO 254 JL = 1 , KDLON ZCNSOL= 1 PBSUR(JL,1)*ZTT(JL,1)*ZTT(JL,3) 2 + PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,4) c! ZCNSOL=ZCNSOL*ZBGND(JL)/(PBSUI(JL)-PBSDD(JL)) JKDD=2*(KFLEV-JK+1)+1 c! ZFU(JL)=ZCNSOL &+(PBINT(JL,JK)-PBHDD(JL,JKDD))-PDISU(JL,JK)-PADJU(JL,JK) c! ZFUP(JL,JK)=ZFU(JL) PFLUC(JL,1,JK)=ZFU(JL) 254 CONTINUE C C IF (NIMP.LT.3) THEN C JL=JLIMPRAD C WRITE(NOUT,890)JL,JK,ZFDN(JL,JK),PDISD(JL,JK),PADJD(JL,JK), C S PBINT(JL,JK), C S ZFUP(JL,JK),PDISU(JL,JK),PADJU(JL,JK),ZCNSOL C END IF 255 CONTINUE C C* 2.6 HEATING-FROM-GROUND OF UPPERMOST LAYER C -------------------------------------- C 260 CONTINUE C DO 262 JA = 1 , KTRAER DO 261 JL = 1 , KDLON ZTT1(JL,JA) = ZTT(JL,JA) 261 CONTINUE 262 CONTINUE C DO 265 JA = 1 , 4 DO 264 JL = 1 , KDLON ZUU(JL,JA) = PABCUCO2(JL,JA,1) - PABCUCO2(JL,JA,KTOPM) 264 CONTINUE 265 CONTINUE DO ja=3,4 DO jl=1,kdlon ztt(jl,ja)=pabcuaer(jl,ja-2,1)/pabcuaer(jl,ja-2,ktopm) ENDDO ENDDO C CALL LWTT(KDLON,pgab(1,1),pgbb(1,1),ZUU,ZTT) C DO 266 JL = 1 , KDLON ZHFGRND= S (PBSUR(JL,1)-PBTOP(JL,1)) S *(ZTT(JL,1)*ZTT(JL,3)-ZTT1(JL,1)*ZTT1(JL,3)) S +(PBSUR(JL,2)-PBTOP(JL,2)) S *(ZTT(JL,2)*ZTT(JL,4)-ZTT1(JL,2)*ZTT1(JL,4)) PHFG(JL,KFLEV) = ZHFGRND 266 CONTINUE C C* 2.7 CLEAR-SKY FLUXES C ---------------- C 270 CONTINUE C IF (NIMP.LT.4) THEN WRITE(NOUT,884) (PFLUC(JLIMPRAD,1,JK),JK = 1 , KFLEV+1) WRITE(NOUT,884) (PFLUC(JLIMPRAD,2,JK),JK = 1 , KFLEV+1) END IF C C ------------------------------------------------------------------ C RETURN C C----------------------------------------------------------------------- C FORMATS C ------- C 884 FORMAT (1X,F7.2,18F6.1,F7.2) 886 FORMAT (1X,20I5) 888 FORMAT (1X,13E9.2) 890 FORMAT (1X,2I4,13F9.2) C END