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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 81 - (hide annotations)
Wed Mar 5 14:38:41 2014 UTC (10 years, 3 months ago) by guez
File size: 8415 byte(s) 
 Converted to free source form files which were still in fixed source
form. The conversion was done using the polish mode of the NAG Fortran
Compiler.

In addition to converting to free source form, the processing of the
files also:

-- indented the code (including comments);

-- set Fortran keywords to uppercase, and set all other identifiers
to lower case;

-- added qualifiers to end statements (for example "end subroutine
conflx", instead of "end");

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