--- trunk/libf/phylmd/Radlwsw/lwvb.f 2013/07/08 18:12:18 71 +++ trunk/phylmd/Radlwsw/lwvb.f90 2014/03/05 14:38:41 81 @@ -1,333 +1,305 @@ - SUBROUTINE LWVB(KUAER,KTRAER, KLIM - R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP - R , PDISD,PDISU,PEMIS,PPMB - R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP - S , PCTS,PFLUC) - use dimens_m - use dimphy - use raddim - use radopt - use raddimlw - IMPLICIT none -C -C----------------------------------------------------------------------- -C PURPOSE. -C -------- -C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL -C INTEGRATION -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 REFERENCE. -C ---------- -C -C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND -C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS -C -C AUTHOR. -C ------- -C JEAN-JACQUES MORCRETTE *ECMWF* -C -C MODIFICATIONS. -C -------------- -C ORIGINAL : 89-07-14 -C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96 -C----------------------------------------------------------------------- -C -C* 0.1 ARGUMENTS -C --------- -C - INTEGER KUAER,KTRAER, KLIM -C - DOUBLE PRECISION PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS - DOUBLE PRECISION PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS - DOUBLE PRECISION PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS - DOUBLE PRECISION PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS - DOUBLE PRECISION PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS - DOUBLE PRECISION PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION - DOUBLE PRECISION PBSUI(KDLON) ! SURFACE PLANCK FUNCTION - DOUBLE PRECISION PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION - DOUBLE PRECISION PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS - DOUBLE PRECISION PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS - DOUBLE PRECISION PEMIS(KDLON) ! SURFACE EMISSIVITY - DOUBLE PRECISION PPMB(KDLON,KFLEV+1) ! PRESSURE MB - DOUBLE PRECISION PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS - DOUBLE PRECISION PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS - DOUBLE PRECISION PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS - DOUBLE PRECISION PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS - DOUBLE PRECISION PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS - DOUBLE PRECISION PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS -C - DOUBLE PRECISION PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES - DOUBLE PRECISION PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM -C -C* LOCAL VARIABLES: -C - DOUBLE PRECISION ZBGND(KDLON) - DOUBLE PRECISION ZFD(KDLON) - DOUBLE PRECISION ZFN10(KDLON) - DOUBLE PRECISION ZFU(KDLON) - DOUBLE PRECISION ZTT(KDLON,NTRA) - DOUBLE PRECISION ZTT1(KDLON,NTRA) - DOUBLE PRECISION ZTT2(KDLON,NTRA) - DOUBLE PRECISION ZUU(KDLON,NUA) - DOUBLE PRECISION ZCNSOL(KDLON) - DOUBLE PRECISION ZCNTOP(KDLON) -C - INTEGER jk, jl, ja - INTEGER jstra, jstru - INTEGER ind1, ind2, ind3, ind4, in, jlim - DOUBLE PRECISION zctstr -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)=1.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 - IN=(JK-1)*NG1P1+1 -C - DO 232 JA=1,KUAER - DO 231 JL=1, KDLON - ZUU(JL,JA)=PABCU(JL,JA,IN) - 231 CONTINUE - 232 CONTINUE -C -C - CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT) -C - DO 234 JL = 1, KDLON - ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1) *ZTT(JL,10) - 2 +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) - 3 +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) - 4 +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) - 5 +PBTOP(JL,5)*ZTT(JL,3) *ZTT(JL,14) - 6 +PBTOP(JL,6)*ZTT(JL,6) *ZTT(JL,15) - ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) - PFLUC(JL,2,JK)=ZFD(JL) - 234 CONTINUE -C - 235 CONTINUE -C - JK = KFLEV+1 - IN=(JK-1)*NG1P1+1 -C - DO 236 JL = 1, KDLON - ZCNTOP(JL)= PBTOP(JL,1) - 1 + PBTOP(JL,2) - 2 + PBTOP(JL,3) - 3 + PBTOP(JL,4) - 4 + PBTOP(JL,5) - 5 + PBTOP(JL,6) - ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) - PFLUC(JL,2,JK)=ZFD(JL) - 236 CONTINUE -C -C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA -C --------------------------------------- -C - 240 CONTINUE -C -C -C* 2.4.1 INITIALIZATION -C -------------- -C - 2410 CONTINUE -C - JLIM = KFLEV -C - IF (.NOT.LEVOIGT) THEN - DO 2412 JK = KFLEV,1,-1 - IF(PPMB(1,JK).LT.10.0) THEN - JLIM=JK - ENDIF - 2412 CONTINUE - ENDIF - KLIM=JLIM -C - IF (.NOT.LEVOIGT) THEN - DO 2414 JA=1,KTRAER - DO 2413 JL=1, KDLON - ZTT1(JL,JA)=1.0 - 2413 CONTINUE - 2414 CONTINUE -C -C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA -C ----------------------------- -C - 2420 CONTINUE -C - DO 2427 JSTRA = KFLEV,JLIM,-1 - JSTRU=(JSTRA-1)*NG1P1+1 -C - DO 2423 JA=1,KUAER - DO 2422 JL=1, KDLON - ZUU(JL,JA)=PABCU(JL,JA,JSTRU) - 2422 CONTINUE - 2423 CONTINUE -C -C - CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT) -C - DO 2424 JL = 1, KDLON - ZCTSTR = - 1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1)) - 1 *(ZTT1(JL,1) *ZTT1(JL,10) - 1 - ZTT (JL,1) *ZTT (JL,10)) - 2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1)) - 2 *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11) - 2 - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11)) - 3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1)) - 3 *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12) - 3 - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12)) - 4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1)) - 4 *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13) - 4 - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13)) - 5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1)) - 5 *(ZTT1(JL,3) *ZTT1(JL,14) - 5 - ZTT (JL,3) *ZTT (JL,14)) - 6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1)) - 6 *(ZTT1(JL,6) *ZTT1(JL,15) - 6 - ZTT (JL,6) *ZTT (JL,15)) - PCTS(JL,JSTRA)=ZCTSTR*0.5 - 2424 CONTINUE - DO 2426 JA=1,KTRAER - DO 2425 JL=1, KDLON - ZTT1(JL,JA)=ZTT(JL,JA) - 2425 CONTINUE - 2426 CONTINUE - 2427 CONTINUE - ENDIF -C Mise a zero de securite pour PCTS en cas de LEVOIGT - IF(LEVOIGT)THEN - DO 2429 JSTRA = 1,KFLEV - DO 2428 JL = 1, KDLON - PCTS(JL,JSTRA)=0. - 2428 CONTINUE - 2429 CONTINUE - ENDIF -C -C -C* 2.5 EXCHANGE WITH LOWER LIMIT -C ------------------------- -C - 250 CONTINUE -C - DO 251 JL = 1, KDLON - ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL)) - S *PFLUC(JL,2,1)-PBINT(JL,1) - 251 CONTINUE -C - JK = 1 - IN=(JK-1)*NG1P1+1 -C - DO 252 JL = 1, KDLON - ZCNSOL(JL)=PBSUR(JL,1) - 1 +PBSUR(JL,2) - 2 +PBSUR(JL,3) - 3 +PBSUR(JL,4) - 4 +PBSUR(JL,5) - 5 +PBSUR(JL,6) - ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) - ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) - PFLUC(JL,1,JK)=ZFU(JL) - 252 CONTINUE -C - DO 257 JK = 2 , KFLEV+1 - IN=(JK-1)*NG1P1+1 -C -C - DO 255 JA=1,KUAER - DO 254 JL=1, KDLON - ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN) - 254 CONTINUE - 255 CONTINUE -C -C - CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT) -C - DO 256 JL = 1, KDLON - ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1) *ZTT(JL,10) - 2 +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) - 3 +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) - 4 +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) - 5 +PBSUR(JL,5)*ZTT(JL,3) *ZTT(JL,14) - 6 +PBSUR(JL,6)*ZTT(JL,6) *ZTT(JL,15) - ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) - ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) - PFLUC(JL,1,JK)=ZFU(JL) - 256 CONTINUE -C -C - 257 CONTINUE -C -C -C -C* 2.7 CLEAR-SKY FLUXES -C ---------------- -C - 270 CONTINUE -C - IF (.NOT.LEVOIGT) THEN - DO 271 JL = 1, KDLON - ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM) - 271 CONTINUE - DO 273 JK = JLIM+1,KFLEV+1 - DO 272 JL = 1, KDLON - ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) - PFLUC(JL,1,JK) = ZFN10(JL) - PFLUC(JL,2,JK) = 0. - 272 CONTINUE - 273 CONTINUE - ENDIF -C -C ------------------------------------------------------------------ -C - RETURN - END +SUBROUTINE lwvb(kuaer, ktraer, klim, pabcu, padjd, padju, pb, pbint, pbsui, & + pbsur, pbtop, pdisd, pdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, & + pgatop, pgbtop, pcts, pfluc) + USE dimens_m + USE dimphy + USE raddim + USE radopt + USE raddimlw + IMPLICIT NONE + + ! ----------------------------------------------------------------------- + ! PURPOSE. + ! -------- + ! INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL + ! INTEGRATION + + ! METHOD. + ! ------- + + ! 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE + ! ATMOSPHERE + ! 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND + ! TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA + ! 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES + + ! REFERENCE. + ! ---------- + + ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND + ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS + + ! AUTHOR. + ! ------- + ! JEAN-JACQUES MORCRETTE *ECMWF* + + ! MODIFICATIONS. + ! -------------- + ! ORIGINAL : 89-07-14 + ! Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96 + ! ----------------------------------------------------------------------- + + ! * 0.1 ARGUMENTS + ! --------- + + INTEGER kuaer, ktraer, klim + + DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS + DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS + DOUBLE PRECISION padju(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS + DOUBLE PRECISION pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS + DOUBLE PRECISION pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS + DOUBLE PRECISION pbsur(kdlon, ninter) ! SPECTRAL SURFACE PLANCK FUNCTION + DOUBLE PRECISION pbsui(kdlon) ! SURFACE PLANCK FUNCTION + DOUBLE PRECISION pbtop(kdlon, ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION + DOUBLE PRECISION pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS + DOUBLE PRECISION pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS + DOUBLE PRECISION pemis(kdlon) ! SURFACE EMISSIVITY + DOUBLE PRECISION ppmb(kdlon, kflev+1) ! PRESSURE MB + DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS + DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS + DOUBLE PRECISION pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS + DOUBLE PRECISION pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS + DOUBLE PRECISION pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS + DOUBLE PRECISION pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS + + DOUBLE PRECISION pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES + DOUBLE PRECISION pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM + + ! * LOCAL VARIABLES: + + DOUBLE PRECISION zbgnd(kdlon) + DOUBLE PRECISION zfd(kdlon) + DOUBLE PRECISION zfn10(kdlon) + DOUBLE PRECISION zfu(kdlon) + DOUBLE PRECISION ztt(kdlon, ntra) + DOUBLE PRECISION ztt1(kdlon, ntra) + DOUBLE PRECISION ztt2(kdlon, ntra) + DOUBLE PRECISION zuu(kdlon, nua) + DOUBLE PRECISION zcnsol(kdlon) + DOUBLE PRECISION zcntop(kdlon) + + INTEGER jk, jl, ja + INTEGER jstra, jstru + INTEGER ind1, ind2, ind3, ind4, in, jlim + DOUBLE PRECISION zctstr + ! ----------------------------------------------------------------------- + + ! * 1. INITIALIZATION + ! -------------- + + + + ! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS + ! --------------------------------- + + + DO ja = 1, ntra + DO jl = 1, kdlon + ztt(jl, ja) = 1.0 + ztt1(jl, ja) = 1.0 + ztt2(jl, ja) = 1.0 + END DO + END DO + + DO ja = 1, nua + DO jl = 1, kdlon + zuu(jl, ja) = 1.0 + END DO + END DO + + ! ------------------------------------------------------------------ + + ! * 2. VERTICAL INTEGRATION + ! -------------------- + + + ind1 = 0 + ind3 = 0 + ind4 = 1 + ind2 = 1 + + + ! * 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE + ! ----------------------------------- + + + DO jk = 1, kflev + in = (jk-1)*ng1p1 + 1 + + DO ja = 1, kuaer + DO jl = 1, kdlon + zuu(jl, ja) = pabcu(jl, ja, in) + END DO + END DO + + + CALL lwtt(pgatop(1,1,1), pgbtop(1,1,1), zuu, ztt) + + DO jl = 1, kdlon + zcntop(jl) = pbtop(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + & + pbtop(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + & + pbtop(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + & + pbtop(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + & + pbtop(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbtop(jl, 6)*ztt(jl, 6)*ztt(jl, & + 15) + zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk) + pfluc(jl, 2, jk) = zfd(jl) + END DO + + END DO + + jk = kflev + 1 + in = (jk-1)*ng1p1 + 1 + + DO jl = 1, kdlon + zcntop(jl) = pbtop(jl, 1) + pbtop(jl, 2) + pbtop(jl, 3) + pbtop(jl, 4) + & + pbtop(jl, 5) + pbtop(jl, 6) + zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk) + pfluc(jl, 2, jk) = zfd(jl) + END DO + + ! * 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA + ! --------------------------------------- + + + + ! * 2.4.1 INITIALIZATION + ! -------------- + + + jlim = kflev + + IF (.NOT. levoigt) THEN + DO jk = kflev, 1, -1 + IF (ppmb(1,jk)<10.0) THEN + jlim = jk + END IF + END DO + END IF + klim = jlim + + IF (.NOT. levoigt) THEN + DO ja = 1, ktraer + DO jl = 1, kdlon + ztt1(jl, ja) = 1.0 + END DO + END DO + + ! * 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA + ! ----------------------------- + + + DO jstra = kflev, jlim, -1 + jstru = (jstra-1)*ng1p1 + 1 + + DO ja = 1, kuaer + DO jl = 1, kdlon + zuu(jl, ja) = pabcu(jl, ja, jstru) + END DO + END DO + + + CALL lwtt(pga(1,1,1,jstra), pgb(1,1,1,jstra), zuu, ztt) + + DO jl = 1, kdlon + zctstr = (pb(jl,1,jstra)+pb(jl,1,jstra+1))* & + (ztt1(jl,1)*ztt1(jl,10)-ztt(jl,1)*ztt(jl,10)) + & + (pb(jl,2,jstra)+pb(jl,2,jstra+1))*(ztt1(jl,2)*ztt1(jl,7)*ztt1(jl,11 & + )-ztt(jl,2)*ztt(jl,7)*ztt(jl,11)) + (pb(jl,3,jstra)+pb(jl,3,jstra+1 & + ))*(ztt1(jl,4)*ztt1(jl,8)*ztt1(jl,12)-ztt(jl,4)*ztt(jl,8)*ztt(jl,12 & + )) + (pb(jl,4,jstra)+pb(jl,4,jstra+1))*(ztt1(jl,5)*ztt1(jl,9)*ztt1( & + jl,13)-ztt(jl,5)*ztt(jl,9)*ztt(jl,13)) + (pb(jl,5,jstra)+pb(jl,5, & + jstra+1))*(ztt1(jl,3)*ztt1(jl,14)-ztt(jl,3)*ztt(jl,14)) + & + (pb(jl,6,jstra)+pb(jl,6,jstra+1))*(ztt1(jl,6)*ztt1(jl,15)-ztt(jl,6) & + *ztt(jl,15)) + pcts(jl, jstra) = zctstr*0.5 + END DO + DO ja = 1, ktraer + DO jl = 1, kdlon + ztt1(jl, ja) = ztt(jl, ja) + END DO + END DO + END DO + END IF + ! Mise a zero de securite pour PCTS en cas de LEVOIGT + IF (levoigt) THEN + DO jstra = 1, kflev + DO jl = 1, kdlon + pcts(jl, jstra) = 0. + END DO + END DO + END IF + + + ! * 2.5 EXCHANGE WITH LOWER LIMIT + ! ------------------------- + + + DO jl = 1, kdlon + zbgnd(jl) = pbsui(jl)*pemis(jl) - (1.-pemis(jl))*pfluc(jl, 2, 1) - & + pbint(jl, 1) + END DO + + jk = 1 + in = (jk-1)*ng1p1 + 1 + + DO jl = 1, kdlon + zcnsol(jl) = pbsur(jl, 1) + pbsur(jl, 2) + pbsur(jl, 3) + pbsur(jl, 4) + & + pbsur(jl, 5) + pbsur(jl, 6) + zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl) + zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk) + pfluc(jl, 1, jk) = zfu(jl) + END DO + + DO jk = 2, kflev + 1 + in = (jk-1)*ng1p1 + 1 + + + DO ja = 1, kuaer + DO jl = 1, kdlon + zuu(jl, ja) = pabcu(jl, ja, 1) - pabcu(jl, ja, in) + END DO + END DO + + + CALL lwtt(pgasur(1,1,1), pgbsur(1,1,1), zuu, ztt) + + DO jl = 1, kdlon + zcnsol(jl) = pbsur(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + & + pbsur(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + & + pbsur(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + & + pbsur(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + & + pbsur(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbsur(jl, 6)*ztt(jl, 6)*ztt(jl, & + 15) + zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl) + zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk) + pfluc(jl, 1, jk) = zfu(jl) + END DO + + + END DO + + + + ! * 2.7 CLEAR-SKY FLUXES + ! ---------------- + + + IF (.NOT. levoigt) THEN + DO jl = 1, kdlon + zfn10(jl) = pfluc(jl, 1, jlim) + pfluc(jl, 2, jlim) + END DO + DO jk = jlim + 1, kflev + 1 + DO jl = 1, kdlon + zfn10(jl) = zfn10(jl) + pcts(jl, jk-1) + pfluc(jl, 1, jk) = zfn10(jl) + pfluc(jl, 2, jk) = 0. + END DO + END DO + END IF + + ! ------------------------------------------------------------------ + + RETURN +END SUBROUTINE lwvb