/[lmdze]/trunk/Sources/phylmd/Radlwsw/lwvb.f
ViewVC logotype

Annotation of /trunk/Sources/phylmd/Radlwsw/lwvb.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 178 - (hide annotations)
Fri Mar 11 18:47:26 2016 UTC (8 years, 3 months ago) by guez
File size: 8282 byte(s) 
Moved variables date0, deltat, datasz_max, ncvar_ids, point, buff_pos,
buffer, regular from module histcom_var to modules where they are
defined.

Removed procedure ioipslmpp, useless for a sequential program.

Added argument datasz_max to histwrite_real (to avoid circular
dependency with histwrite).

Removed useless variables and computations everywhere.

Changed real litteral constants from default kind to double precision
in lwb, lwu, lwvn, sw1s, swtt, swtt1, swu.

Removed unused arguments: paer of sw, sw1s, sw2s, swclr; pcldsw of
sw1s, sw2s; pdsig, prayl of swr; co2_ppm of clmain, clqh; tsol of
transp_lay; nsrf of screenp; kcrit and kknu of gwstress; pstd of
orosetup.

Added output of relative humidity.
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 zuu(kdlon, nua)
78     DOUBLE PRECISION zcnsol(kdlon)
79     DOUBLE PRECISION zcntop(kdlon)
80    
81     INTEGER jk, jl, ja
82     INTEGER jstra, jstru
83 guez 178 INTEGER in, jlim
84 guez 81 DOUBLE PRECISION zctstr
85     ! -----------------------------------------------------------------------
86    
87     ! * 1. INITIALIZATION
88     ! --------------
89    
90    
91    
92     ! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
93     ! ---------------------------------
94    
95    
96     DO ja = 1, ntra
97     DO jl = 1, kdlon
98     ztt(jl, ja) = 1.0
99     ztt1(jl, ja) = 1.0
100     END DO
101     END DO
102    
103     DO ja = 1, nua
104     DO jl = 1, kdlon
105     zuu(jl, ja) = 1.0
106     END DO
107     END DO
108    
109     ! ------------------------------------------------------------------
110    
111     ! * 2. VERTICAL INTEGRATION
112     ! --------------------
113    
114     ! * 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE
115     ! -----------------------------------
116    
117    
118     DO jk = 1, kflev
119     in = (jk-1)*ng1p1 + 1
120    
121     DO ja = 1, kuaer
122     DO jl = 1, kdlon
123     zuu(jl, ja) = pabcu(jl, ja, in)
124     END DO
125     END DO
126    
127    
128     CALL lwtt(pgatop(1,1,1), pgbtop(1,1,1), zuu, ztt)
129    
130     DO jl = 1, kdlon
131     zcntop(jl) = pbtop(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + &
132     pbtop(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
133     pbtop(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
134     pbtop(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
135     pbtop(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbtop(jl, 6)*ztt(jl, 6)*ztt(jl, &
136     15)
137     zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
138     pfluc(jl, 2, jk) = zfd(jl)
139     END DO
140    
141     END DO
142    
143     jk = kflev + 1
144     in = (jk-1)*ng1p1 + 1
145    
146     DO jl = 1, kdlon
147     zcntop(jl) = pbtop(jl, 1) + pbtop(jl, 2) + pbtop(jl, 3) + pbtop(jl, 4) + &
148     pbtop(jl, 5) + pbtop(jl, 6)
149     zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
150     pfluc(jl, 2, jk) = zfd(jl)
151     END DO
152    
153     ! * 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
154     ! ---------------------------------------
155    
156    
157    
158     ! * 2.4.1 INITIALIZATION
159     ! --------------
160    
161    
162     jlim = kflev
163    
164     IF (.NOT. levoigt) THEN
165     DO jk = kflev, 1, -1
166     IF (ppmb(1,jk)<10.0) THEN
167     jlim = jk
168     END IF
169     END DO
170     END IF
171     klim = jlim
172    
173     IF (.NOT. levoigt) THEN
174     DO ja = 1, ktraer
175     DO jl = 1, kdlon
176     ztt1(jl, ja) = 1.0
177     END DO
178     END DO
179    
180     ! * 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA
181     ! -----------------------------
182    
183    
184     DO jstra = kflev, jlim, -1
185     jstru = (jstra-1)*ng1p1 + 1
186    
187     DO ja = 1, kuaer
188     DO jl = 1, kdlon
189     zuu(jl, ja) = pabcu(jl, ja, jstru)
190     END DO
191     END DO
192    
193    
194     CALL lwtt(pga(1,1,1,jstra), pgb(1,1,1,jstra), zuu, ztt)
195    
196     DO jl = 1, kdlon
197     zctstr = (pb(jl,1,jstra)+pb(jl,1,jstra+1))* &
198     (ztt1(jl,1)*ztt1(jl,10)-ztt(jl,1)*ztt(jl,10)) + &
199     (pb(jl,2,jstra)+pb(jl,2,jstra+1))*(ztt1(jl,2)*ztt1(jl,7)*ztt1(jl,11 &
200     )-ztt(jl,2)*ztt(jl,7)*ztt(jl,11)) + (pb(jl,3,jstra)+pb(jl,3,jstra+1 &
201     ))*(ztt1(jl,4)*ztt1(jl,8)*ztt1(jl,12)-ztt(jl,4)*ztt(jl,8)*ztt(jl,12 &
202     )) + (pb(jl,4,jstra)+pb(jl,4,jstra+1))*(ztt1(jl,5)*ztt1(jl,9)*ztt1( &
203     jl,13)-ztt(jl,5)*ztt(jl,9)*ztt(jl,13)) + (pb(jl,5,jstra)+pb(jl,5, &
204     jstra+1))*(ztt1(jl,3)*ztt1(jl,14)-ztt(jl,3)*ztt(jl,14)) + &
205     (pb(jl,6,jstra)+pb(jl,6,jstra+1))*(ztt1(jl,6)*ztt1(jl,15)-ztt(jl,6) &
206     *ztt(jl,15))
207     pcts(jl, jstra) = zctstr*0.5
208     END DO
209     DO ja = 1, ktraer
210     DO jl = 1, kdlon
211     ztt1(jl, ja) = ztt(jl, ja)
212     END DO
213     END DO
214     END DO
215     END IF
216     ! Mise a zero de securite pour PCTS en cas de LEVOIGT
217     IF (levoigt) THEN
218     DO jstra = 1, kflev
219     DO jl = 1, kdlon
220     pcts(jl, jstra) = 0.
221     END DO
222     END DO
223     END IF
224    
225    
226     ! * 2.5 EXCHANGE WITH LOWER LIMIT
227     ! -------------------------
228    
229    
230     DO jl = 1, kdlon
231     zbgnd(jl) = pbsui(jl)*pemis(jl) - (1.-pemis(jl))*pfluc(jl, 2, 1) - &
232     pbint(jl, 1)
233     END DO
234    
235     jk = 1
236     in = (jk-1)*ng1p1 + 1
237    
238     DO jl = 1, kdlon
239     zcnsol(jl) = pbsur(jl, 1) + pbsur(jl, 2) + pbsur(jl, 3) + pbsur(jl, 4) + &
240     pbsur(jl, 5) + pbsur(jl, 6)
241     zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
242     zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
243     pfluc(jl, 1, jk) = zfu(jl)
244     END DO
245    
246     DO jk = 2, kflev + 1
247     in = (jk-1)*ng1p1 + 1
248    
249    
250     DO ja = 1, kuaer
251     DO jl = 1, kdlon
252     zuu(jl, ja) = pabcu(jl, ja, 1) - pabcu(jl, ja, in)
253     END DO
254     END DO
255    
256    
257     CALL lwtt(pgasur(1,1,1), pgbsur(1,1,1), zuu, ztt)
258    
259     DO jl = 1, kdlon
260     zcnsol(jl) = pbsur(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + &
261     pbsur(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
262     pbsur(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
263     pbsur(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
264     pbsur(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbsur(jl, 6)*ztt(jl, 6)*ztt(jl, &
265     15)
266     zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
267     zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
268     pfluc(jl, 1, jk) = zfu(jl)
269     END DO
270    
271    
272     END DO
273    
274    
275    
276     ! * 2.7 CLEAR-SKY FLUXES
277     ! ----------------
278    
279    
280     IF (.NOT. levoigt) THEN
281     DO jl = 1, kdlon
282     zfn10(jl) = pfluc(jl, 1, jlim) + pfluc(jl, 2, jlim)
283     END DO
284     DO jk = jlim + 1, kflev + 1
285     DO jl = 1, kdlon
286     zfn10(jl) = zfn10(jl) + pcts(jl, jk-1)
287     pfluc(jl, 1, jk) = zfn10(jl)
288     pfluc(jl, 2, jk) = 0.
289     END DO
290     END DO
291     END IF
292    
293     ! ------------------------------------------------------------------
294    
295     RETURN
296     END SUBROUTINE lwvb
  ViewVC Help
Powered by ViewVC 1.1.21