/[lmdze]/trunk/phylmd/Radlwsw/lwvb.f90
ViewVC logotype

Diff of /trunk/phylmd/Radlwsw/lwvb.f90

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/phylmd/Radlwsw/lwvb.f revision 76 by guez, Fri Nov 15 18:45:49 2013 UTC trunk/phylmd/Radlwsw/lwvb.f90 revision 81 by guez, Wed Mar 5 14:38:41 2014 UTC
# Line 1  Line 1 
1        SUBROUTINE LWVB(KUAER,KTRAER, KLIM  SUBROUTINE lwvb(kuaer, ktraer, klim, pabcu, padjd, padju, pb, pbint, pbsui, &
2       R  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP      pbsur, pbtop, pdisd, pdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, &
3       R  , PDISD,PDISU,PEMIS,PPMB      pgatop, pgbtop, pcts, pfluc)
4       R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP    USE dimens_m
5       S  , PCTS,PFLUC)    USE dimphy
6        use dimens_m    USE raddim
7        use dimphy    USE radopt
8        use raddim    USE raddimlw
9        use radopt    IMPLICIT NONE
10              use raddimlw  
11        IMPLICIT none    ! -----------------------------------------------------------------------
12  C    ! PURPOSE.
13  C-----------------------------------------------------------------------    ! --------
14  C     PURPOSE.    ! INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
15  C     --------    ! INTEGRATION
16  C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL  
17  C           INTEGRATION    ! METHOD.
18  C    ! -------
19  C     METHOD.  
20  C     -------    ! 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
21  C    ! ATMOSPHERE
22  C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE    ! 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
23  C     ATMOSPHERE    ! TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
24  C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND    ! 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
25  C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA  
26  C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES    ! REFERENCE.
27  C    ! ----------
28  C     REFERENCE.  
29  C     ----------    ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
30  C    ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
31  C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND  
32  C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS    ! AUTHOR.
33  C    ! -------
34  C     AUTHOR.    ! JEAN-JACQUES MORCRETTE  *ECMWF*
35  C     -------  
36  C        JEAN-JACQUES MORCRETTE  *ECMWF*    ! MODIFICATIONS.
37  C    ! --------------
38  C     MODIFICATIONS.    ! ORIGINAL : 89-07-14
39  C     --------------    ! Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
40  C        ORIGINAL : 89-07-14    ! -----------------------------------------------------------------------
41  C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96  
42  C-----------------------------------------------------------------------    ! *       0.1   ARGUMENTS
43  C    ! ---------
44  C*       0.1   ARGUMENTS  
45  C              ---------    INTEGER kuaer, ktraer, klim
46  C  
47        INTEGER KUAER,KTRAER, KLIM    DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
48  C    DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS
49        DOUBLE PRECISION PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS    DOUBLE PRECISION padju(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS
50        DOUBLE PRECISION PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS    DOUBLE PRECISION pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
51        DOUBLE PRECISION PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS    DOUBLE PRECISION pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS
52        DOUBLE PRECISION PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS    DOUBLE PRECISION pbsur(kdlon, ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
53        DOUBLE PRECISION PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS    DOUBLE PRECISION pbsui(kdlon) ! SURFACE PLANCK FUNCTION
54        DOUBLE PRECISION PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION    DOUBLE PRECISION pbtop(kdlon, ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
55        DOUBLE PRECISION PBSUI(KDLON) ! SURFACE PLANCK FUNCTION    DOUBLE PRECISION pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
56        DOUBLE PRECISION PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION    DOUBLE PRECISION pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
57        DOUBLE PRECISION PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS    DOUBLE PRECISION pemis(kdlon) ! SURFACE EMISSIVITY
58        DOUBLE PRECISION PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS    DOUBLE PRECISION ppmb(kdlon, kflev+1) ! PRESSURE MB
59        DOUBLE PRECISION PEMIS(KDLON) ! SURFACE EMISSIVITY    DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
60        DOUBLE PRECISION PPMB(KDLON,KFLEV+1) ! PRESSURE MB    DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
61        DOUBLE PRECISION PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS    DOUBLE PRECISION pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
62        DOUBLE PRECISION PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS    DOUBLE PRECISION pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
63        DOUBLE PRECISION PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS    DOUBLE PRECISION pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
64        DOUBLE PRECISION PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS    DOUBLE PRECISION pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
65        DOUBLE PRECISION PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS  
66        DOUBLE PRECISION PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS    DOUBLE PRECISION pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
67  C    DOUBLE PRECISION pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM
68        DOUBLE PRECISION PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES  
69        DOUBLE PRECISION PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM    ! * LOCAL VARIABLES:
70  C  
71  C* LOCAL VARIABLES:    DOUBLE PRECISION zbgnd(kdlon)
72  C    DOUBLE PRECISION zfd(kdlon)
73        DOUBLE PRECISION ZBGND(KDLON)    DOUBLE PRECISION zfn10(kdlon)
74        DOUBLE PRECISION ZFD(KDLON)    DOUBLE PRECISION zfu(kdlon)
75        DOUBLE PRECISION  ZFN10(KDLON)    DOUBLE PRECISION ztt(kdlon, ntra)
76        DOUBLE PRECISION ZFU(KDLON)    DOUBLE PRECISION ztt1(kdlon, ntra)
77        DOUBLE PRECISION  ZTT(KDLON,NTRA)    DOUBLE PRECISION ztt2(kdlon, ntra)
78        DOUBLE PRECISION ZTT1(KDLON,NTRA)    DOUBLE PRECISION zuu(kdlon, nua)
79        DOUBLE PRECISION ZTT2(KDLON,NTRA)    DOUBLE PRECISION zcnsol(kdlon)
80        DOUBLE PRECISION  ZUU(KDLON,NUA)    DOUBLE PRECISION zcntop(kdlon)
81        DOUBLE PRECISION ZCNSOL(KDLON)  
82        DOUBLE PRECISION ZCNTOP(KDLON)    INTEGER jk, jl, ja
83  C    INTEGER jstra, jstru
84        INTEGER jk, jl, ja    INTEGER ind1, ind2, ind3, ind4, in, jlim
85        INTEGER jstra, jstru    DOUBLE PRECISION zctstr
86        INTEGER ind1, ind2, ind3, ind4, in, jlim    ! -----------------------------------------------------------------------
87        DOUBLE PRECISION zctstr  
88  C-----------------------------------------------------------------------    ! *         1.    INITIALIZATION
89  C    ! --------------
90  C*         1.    INITIALIZATION  
91  C                --------------  
92  C  
93   100  CONTINUE    ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
94  C    ! ---------------------------------
95  C  
96  C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS  
97  C                  ---------------------------------    DO ja = 1, ntra
98  C      DO jl = 1, kdlon
99   120  CONTINUE        ztt(jl, ja) = 1.0
100  C        ztt1(jl, ja) = 1.0
101        DO 122 JA=1,NTRA        ztt2(jl, ja) = 1.0
102        DO 121 JL=1, KDLON      END DO
103        ZTT (JL,JA)=1.0    END DO
104        ZTT1(JL,JA)=1.0  
105        ZTT2(JL,JA)=1.0    DO ja = 1, nua
106   121  CONTINUE      DO jl = 1, kdlon
107   122  CONTINUE        zuu(jl, ja) = 1.0
108  C      END DO
109        DO 124 JA=1,NUA    END DO
110        DO 123 JL=1, KDLON  
111        ZUU(JL,JA)=1.0    ! ------------------------------------------------------------------
112   123  CONTINUE  
113   124  CONTINUE    ! *         2.      VERTICAL INTEGRATION
114  C    ! --------------------
115  C     ------------------------------------------------------------------  
116  C  
117  C*         2.      VERTICAL INTEGRATION    ind1 = 0
118  C                  --------------------    ind3 = 0
119  C    ind4 = 1
120   200  CONTINUE    ind2 = 1
121  C  
122        IND1=0  
123        IND3=0    ! *         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
124        IND4=1    ! -----------------------------------
125        IND2=1  
126  C  
127  C    DO jk = 1, kflev
128  C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE      in = (jk-1)*ng1p1 + 1
129  C                  -----------------------------------  
130  C      DO ja = 1, kuaer
131   230  CONTINUE        DO jl = 1, kdlon
132  C          zuu(jl, ja) = pabcu(jl, ja, in)
133        DO 235 JK = 1 , KFLEV        END DO
134        IN=(JK-1)*NG1P1+1      END DO
135  C  
136        DO 232 JA=1,KUAER  
137        DO 231 JL=1, KDLON      CALL lwtt(pgatop(1,1,1), pgbtop(1,1,1), zuu, ztt)
138        ZUU(JL,JA)=PABCU(JL,JA,IN)  
139   231  CONTINUE      DO jl = 1, kdlon
140   232  CONTINUE        zcntop(jl) = pbtop(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + &
141  C          pbtop(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
142  C          pbtop(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
143        CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)          pbtop(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
144  C          pbtop(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbtop(jl, 6)*ztt(jl, 6)*ztt(jl, &
145        DO 234 JL = 1, KDLON          15)
146        ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)        zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
147       2      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)        pfluc(jl, 2, jk) = zfd(jl)
148       3      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)      END DO
149       4      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)  
150       5      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)    END DO
151       6      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)  
152        ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)    jk = kflev + 1
153        PFLUC(JL,2,JK)=ZFD(JL)    in = (jk-1)*ng1p1 + 1
154   234  CONTINUE  
155  C    DO jl = 1, kdlon
156   235  CONTINUE      zcntop(jl) = pbtop(jl, 1) + pbtop(jl, 2) + pbtop(jl, 3) + pbtop(jl, 4) + &
157  C        pbtop(jl, 5) + pbtop(jl, 6)
158        JK = KFLEV+1      zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
159        IN=(JK-1)*NG1P1+1      pfluc(jl, 2, jk) = zfd(jl)
160  C    END DO
161        DO 236 JL = 1, KDLON  
162        ZCNTOP(JL)= PBTOP(JL,1)    ! *         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
163       1   + PBTOP(JL,2)    ! ---------------------------------------
164       2   + PBTOP(JL,3)  
165       3   + PBTOP(JL,4)  
166       4   + PBTOP(JL,5)  
167       5   + PBTOP(JL,6)    ! *         2.4.1   INITIALIZATION
168        ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)    ! --------------
169        PFLUC(JL,2,JK)=ZFD(JL)  
170   236  CONTINUE  
171  C    jlim = kflev
172  C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA  
173  C                  ---------------------------------------    IF (.NOT. levoigt) THEN
174  C      DO jk = kflev, 1, -1
175   240  CONTINUE        IF (ppmb(1,jk)<10.0) THEN
176  C          jlim = jk
177  C        END IF
178  C*         2.4.1   INITIALIZATION      END DO
179  C                  --------------    END IF
180  C    klim = jlim
181   2410 CONTINUE  
182  C    IF (.NOT. levoigt) THEN
183        JLIM = KFLEV      DO ja = 1, ktraer
184  C        DO jl = 1, kdlon
185        IF (.NOT.LEVOIGT) THEN          ztt1(jl, ja) = 1.0
186        DO 2412 JK = KFLEV,1,-1        END DO
187        IF(PPMB(1,JK).LT.10.0) THEN      END DO
188           JLIM=JK  
189        ENDIF        ! *         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
190   2412 CONTINUE      ! -----------------------------
191        ENDIF  
192        KLIM=JLIM  
193  C      DO jstra = kflev, jlim, -1
194        IF (.NOT.LEVOIGT) THEN        jstru = (jstra-1)*ng1p1 + 1
195          DO 2414 JA=1,KTRAER  
196          DO 2413 JL=1, KDLON        DO ja = 1, kuaer
197          ZTT1(JL,JA)=1.0          DO jl = 1, kdlon
198   2413   CONTINUE            zuu(jl, ja) = pabcu(jl, ja, jstru)
199   2414   CONTINUE          END DO
200  C        END DO
201  C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA  
202  C                  -----------------------------  
203  C        CALL lwtt(pga(1,1,1,jstra), pgb(1,1,1,jstra), zuu, ztt)
204   2420   CONTINUE  
205  C        DO jl = 1, kdlon
206          DO 2427 JSTRA = KFLEV,JLIM,-1          zctstr = (pb(jl,1,jstra)+pb(jl,1,jstra+1))* &
207          JSTRU=(JSTRA-1)*NG1P1+1            (ztt1(jl,1)*ztt1(jl,10)-ztt(jl,1)*ztt(jl,10)) + &
208  C            (pb(jl,2,jstra)+pb(jl,2,jstra+1))*(ztt1(jl,2)*ztt1(jl,7)*ztt1(jl,11 &
209          DO 2423 JA=1,KUAER            )-ztt(jl,2)*ztt(jl,7)*ztt(jl,11)) + (pb(jl,3,jstra)+pb(jl,3,jstra+1 &
210          DO 2422 JL=1, KDLON            ))*(ztt1(jl,4)*ztt1(jl,8)*ztt1(jl,12)-ztt(jl,4)*ztt(jl,8)*ztt(jl,12 &
211          ZUU(JL,JA)=PABCU(JL,JA,JSTRU)            )) + (pb(jl,4,jstra)+pb(jl,4,jstra+1))*(ztt1(jl,5)*ztt1(jl,9)*ztt1( &
212   2422   CONTINUE            jl,13)-ztt(jl,5)*ztt(jl,9)*ztt(jl,13)) + (pb(jl,5,jstra)+pb(jl,5, &
213   2423   CONTINUE            jstra+1))*(ztt1(jl,3)*ztt1(jl,14)-ztt(jl,3)*ztt(jl,14)) + &
214  C            (pb(jl,6,jstra)+pb(jl,6,jstra+1))*(ztt1(jl,6)*ztt1(jl,15)-ztt(jl,6) &
215  C            *ztt(jl,15))
216          CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)          pcts(jl, jstra) = zctstr*0.5
217  C        END DO
218          DO 2424 JL = 1, KDLON        DO ja = 1, ktraer
219          ZCTSTR =          DO jl = 1, kdlon
220       1   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))            ztt1(jl, ja) = ztt(jl, ja)
221       1       *(ZTT1(JL,1)           *ZTT1(JL,10)          END DO
222       1       - ZTT (JL,1)           *ZTT (JL,10))        END DO
223       2  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))      END DO
224       2       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)    END IF
225       2       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))    ! Mise a zero de securite pour PCTS en cas de LEVOIGT
226       3  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))    IF (levoigt) THEN
227       3       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)      DO jstra = 1, kflev
228       3       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))        DO jl = 1, kdlon
229       4  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))          pcts(jl, jstra) = 0.
230       4       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)        END DO
231       4       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))      END DO
232       5  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))    END IF
233       5       *(ZTT1(JL,3)           *ZTT1(JL,14)  
234       5       - ZTT (JL,3)           *ZTT (JL,14))  
235       6  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))    ! *         2.5     EXCHANGE WITH LOWER LIMIT
236       6       *(ZTT1(JL,6)           *ZTT1(JL,15)    ! -------------------------
237       6       - ZTT (JL,6)           *ZTT (JL,15))  
238          PCTS(JL,JSTRA)=ZCTSTR*0.5  
239   2424   CONTINUE    DO jl = 1, kdlon
240          DO 2426 JA=1,KTRAER      zbgnd(jl) = pbsui(jl)*pemis(jl) - (1.-pemis(jl))*pfluc(jl, 2, 1) - &
241          DO 2425 JL=1, KDLON        pbint(jl, 1)
242          ZTT1(JL,JA)=ZTT(JL,JA)    END DO
243   2425   CONTINUE  
244   2426   CONTINUE    jk = 1
245   2427   CONTINUE    in = (jk-1)*ng1p1 + 1
246        ENDIF  
247  C Mise a zero de securite pour PCTS en cas de LEVOIGT    DO jl = 1, kdlon
248        IF(LEVOIGT)THEN      zcnsol(jl) = pbsur(jl, 1) + pbsur(jl, 2) + pbsur(jl, 3) + pbsur(jl, 4) + &
249          DO 2429 JSTRA = 1,KFLEV        pbsur(jl, 5) + pbsur(jl, 6)
250          DO 2428 JL = 1, KDLON      zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
251            PCTS(JL,JSTRA)=0.      zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
252   2428   CONTINUE      pfluc(jl, 1, jk) = zfu(jl)
253   2429   CONTINUE    END DO
254        ENDIF  
255  C    DO jk = 2, kflev + 1
256  C      in = (jk-1)*ng1p1 + 1
257  C*         2.5     EXCHANGE WITH LOWER LIMIT  
258  C                  -------------------------  
259  C      DO ja = 1, kuaer
260   250  CONTINUE        DO jl = 1, kdlon
261  C          zuu(jl, ja) = pabcu(jl, ja, 1) - pabcu(jl, ja, in)
262        DO 251 JL = 1, KDLON        END DO
263        ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))      END DO
264       S               *PFLUC(JL,2,1)-PBINT(JL,1)  
265   251  CONTINUE  
266  C      CALL lwtt(pgasur(1,1,1), pgbsur(1,1,1), zuu, ztt)
267        JK = 1  
268        IN=(JK-1)*NG1P1+1      DO jl = 1, kdlon
269  C        zcnsol(jl) = pbsur(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + &
270        DO 252 JL = 1, KDLON          pbsur(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
271        ZCNSOL(JL)=PBSUR(JL,1)          pbsur(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
272       1 +PBSUR(JL,2)          pbsur(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
273       2 +PBSUR(JL,3)          pbsur(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbsur(jl, 6)*ztt(jl, 6)*ztt(jl, &
274       3 +PBSUR(JL,4)          15)
275       4 +PBSUR(JL,5)        zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
276       5 +PBSUR(JL,6)        zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
277        ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)        pfluc(jl, 1, jk) = zfu(jl)
278        ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)      END DO
279        PFLUC(JL,1,JK)=ZFU(JL)  
280   252  CONTINUE  
281  C    END DO
282        DO 257 JK = 2 , KFLEV+1  
283        IN=(JK-1)*NG1P1+1  
284  C  
285  C    ! *         2.7     CLEAR-SKY FLUXES
286        DO 255 JA=1,KUAER    ! ----------------
287        DO 254 JL=1, KDLON  
288        ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)  
289   254  CONTINUE    IF (.NOT. levoigt) THEN
290   255  CONTINUE      DO jl = 1, kdlon
291  C        zfn10(jl) = pfluc(jl, 1, jlim) + pfluc(jl, 2, jlim)
292  C      END DO
293        CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)      DO jk = jlim + 1, kflev + 1
294  C        DO jl = 1, kdlon
295        DO 256 JL = 1, KDLON          zfn10(jl) = zfn10(jl) + pcts(jl, jk-1)
296        ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)          pfluc(jl, 1, jk) = zfn10(jl)
297       2      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)          pfluc(jl, 2, jk) = 0.
298       3      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)        END DO
299       4      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)      END DO
300       5      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)    END IF
301       6      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)  
302        ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)    ! ------------------------------------------------------------------
303        ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)  
304        PFLUC(JL,1,JK)=ZFU(JL)    RETURN
305   256  CONTINUE  END SUBROUTINE lwvb
 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  
Legend:
Removed from v.76  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21