1 |
|
|
|
2 |
|
|
! $Header$ |
3 |
|
|
|
4 |
|
33494256 |
SUBROUTINE ajsec(paprs, pplay, t, q, limbas, d_t, d_q) |
5 |
|
|
USE dimphy |
6 |
|
|
IMPLICIT NONE |
7 |
|
|
! ====================================================================== |
8 |
|
|
! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 |
9 |
|
|
! Objet: ajustement sec (adaptation du GCM du LMD) |
10 |
|
|
! ====================================================================== |
11 |
|
|
! Arguments: |
12 |
|
|
! t-------input-R- Temperature |
13 |
|
|
|
14 |
|
|
! d_t-----output-R-Incrementation de la temperature |
15 |
|
|
! ====================================================================== |
16 |
|
|
include "YOMCST.h" |
17 |
|
|
REAL paprs(klon, klev+1), pplay(klon, klev) |
18 |
|
|
REAL t(klon, klev), q(klon, klev) |
19 |
|
|
REAL d_t(klon, klev), d_q(klon, klev) |
20 |
|
|
|
21 |
|
|
INTEGER limbas(klon), limhau ! les couches a ajuster |
22 |
|
|
|
23 |
|
|
LOGICAL mixq |
24 |
|
|
! cc PARAMETER (mixq=.TRUE.) |
25 |
|
|
PARAMETER (mixq=.FALSE.) |
26 |
|
|
|
27 |
|
864 |
REAL zh(klon, klev) |
28 |
|
864 |
REAL zho(klon, klev) |
29 |
|
864 |
REAL zq(klon, klev) |
30 |
|
864 |
REAL zpk(klon, klev) |
31 |
|
864 |
REAL zpkdp(klon, klev) |
32 |
|
|
REAL hm, sm, qm |
33 |
|
432 |
LOGICAL modif(klon), down |
34 |
|
|
INTEGER i, k, k1, k2 |
35 |
|
|
|
36 |
|
|
! Initialisation: |
37 |
|
|
|
38 |
|
|
! ym |
39 |
|
|
limhau = klev |
40 |
|
|
|
41 |
✓✓ |
17280 |
DO k = 1, klev |
42 |
✓✓ |
16764192 |
DO i = 1, klon |
43 |
|
16746912 |
d_t(i, k) = 0.0 |
44 |
|
16763760 |
d_q(i, k) = 0.0 |
45 |
|
|
END DO |
46 |
|
|
END DO |
47 |
|
|
! ------------------------------------- detection des profils a modifier |
48 |
✓✓ |
17280 |
DO k = 1, limhau |
49 |
✓✓ |
16764192 |
DO i = 1, klon |
50 |
|
16746912 |
zpk(i, k) = pplay(i, k)**rkappa |
51 |
|
16746912 |
zh(i, k) = rcpd*t(i, k)/zpk(i, k) |
52 |
|
16746912 |
zho(i, k) = zh(i, k) |
53 |
|
16763760 |
zq(i, k) = q(i, k) |
54 |
|
|
END DO |
55 |
|
|
END DO |
56 |
|
|
|
57 |
✓✓ |
17280 |
DO k = 1, limhau |
58 |
✓✓ |
16764192 |
DO i = 1, klon |
59 |
|
16763760 |
zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1)) |
60 |
|
|
END DO |
61 |
|
|
END DO |
62 |
|
|
|
63 |
✓✓ |
429840 |
DO i = 1, klon |
64 |
|
429840 |
modif(i) = .FALSE. |
65 |
|
|
END DO |
66 |
✓✓ |
16848 |
DO k = 2, limhau |
67 |
✓✓ |
16334352 |
DO i = 1, klon |
68 |
✓✓✓✓
|
16333920 |
IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN |
69 |
✓✓ |
12009419 |
IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE. |
70 |
|
|
END IF |
71 |
|
|
END DO |
72 |
|
|
END DO |
73 |
|
|
! ------------------------------------- correction des profils instables |
74 |
✓✓ |
429840 |
DO i = 1, klon |
75 |
✓✓ |
429840 |
IF (modif(i)) THEN |
76 |
|
91669 |
k2 = limbas(i) |
77 |
|
|
8000 CONTINUE |
78 |
|
3351573 |
k2 = k2 + 1 |
79 |
✓✓ |
3351573 |
IF (k2>limhau) GO TO 8001 |
80 |
✓✓ |
3259904 |
IF (zh(i,k2)<zh(i,k2-1)) THEN |
81 |
|
|
k1 = k2 - 1 |
82 |
|
|
k = k1 |
83 |
|
112326 |
sm = zpkdp(i, k2) |
84 |
|
|
hm = zh(i, k2) |
85 |
|
112326 |
qm = zq(i, k2) |
86 |
|
|
8020 CONTINUE |
87 |
|
220983 |
sm = sm + zpkdp(i, k) |
88 |
|
220983 |
hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm |
89 |
|
220983 |
qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm |
90 |
|
|
down = .FALSE. |
91 |
✓✓ |
220983 |
IF (k1/=limbas(i)) THEN |
92 |
✓✓ |
76194 |
IF (hm<zh(i,k1-1)) down = .TRUE. |
93 |
|
|
END IF |
94 |
|
|
IF (down) THEN |
95 |
|
|
k1 = k1 - 1 |
96 |
|
|
k = k1 |
97 |
|
|
ELSE |
98 |
✗✓ |
211420 |
IF ((k2==limhau)) GO TO 8021 |
99 |
✓✓ |
211420 |
IF ((zh(i,k2+1)>=hm)) GO TO 8021 |
100 |
|
|
k2 = k2 + 1 |
101 |
|
|
k = k2 |
102 |
|
|
END IF |
103 |
|
112326 |
GO TO 8020 |
104 |
|
|
8021 CONTINUE |
105 |
|
|
! ------------ nouveau profil : constant (valeur moyenne) |
106 |
✓✓ |
445635 |
DO k = k1, k2 |
107 |
|
333309 |
zh(i, k) = hm |
108 |
|
445635 |
zq(i, k) = qm |
109 |
|
|
END DO |
110 |
|
112326 |
k2 = k2 + 1 |
111 |
|
|
END IF |
112 |
|
91669 |
GO TO 8000 |
113 |
|
|
8001 CONTINUE |
114 |
|
|
END IF |
115 |
|
|
END DO |
116 |
|
|
|
117 |
✓✓ |
17280 |
DO k = 1, limhau |
118 |
✓✓ |
16764192 |
DO i = 1, klon |
119 |
|
16746912 |
d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd |
120 |
|
16763760 |
d_q(i, k) = zq(i, k) - q(i, k) |
121 |
|
|
END DO |
122 |
|
|
END DO |
123 |
|
|
|
124 |
|
|
! FH : les d_q et d_t sont maintenant calcules de facon a valoir |
125 |
|
|
! effectivement 0. si on ne fait rien. |
126 |
|
|
|
127 |
|
|
! IF (limbas.GT.1) THEN |
128 |
|
|
! DO k = 1, limbas-1 |
129 |
|
|
! DO i = 1, klon |
130 |
|
|
! d_t(i,k) = 0.0 |
131 |
|
|
! d_q(i,k) = 0.0 |
132 |
|
|
! ENDDO |
133 |
|
|
! ENDDO |
134 |
|
|
! ENDIF |
135 |
|
|
|
136 |
|
|
! IF (limhau.LT.klev) THEN |
137 |
|
|
! DO k = limhau+1, klev |
138 |
|
|
! DO i = 1, klon |
139 |
|
|
! d_t(i,k) = 0.0 |
140 |
|
|
! d_q(i,k) = 0.0 |
141 |
|
|
! ENDDO |
142 |
|
|
! ENDDO |
143 |
|
|
! ENDIF |
144 |
|
|
|
145 |
|
|
IF (.NOT. mixq) THEN |
146 |
✓✓ |
17280 |
DO k = 1, klev |
147 |
✓✓ |
16764192 |
DO i = 1, klon |
148 |
|
16763760 |
d_q(i, k) = 0.0 |
149 |
|
|
END DO |
150 |
|
|
END DO |
151 |
|
|
END IF |
152 |
|
|
|
153 |
|
432 |
RETURN |
154 |
|
|
END SUBROUTINE ajsec |
155 |
|
|
|
156 |
|
|
SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q) |
157 |
|
|
USE dimphy |
158 |
|
|
IMPLICIT NONE |
159 |
|
|
! ====================================================================== |
160 |
|
|
! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 |
161 |
|
|
! Objet: ajustement sec (adaptation du GCM du LMD) |
162 |
|
|
! ====================================================================== |
163 |
|
|
! Arguments: |
164 |
|
|
! t-------input-R- Temperature |
165 |
|
|
|
166 |
|
|
! d_t-----output-R-Incrementation de la temperature |
167 |
|
|
! ====================================================================== |
168 |
|
|
include "YOMCST.h" |
169 |
|
|
REAL paprs(klon, klev+1), pplay(klon, klev) |
170 |
|
|
REAL t(klon, klev), q(klon, klev) |
171 |
|
|
REAL d_t(klon, klev), d_q(klon, klev) |
172 |
|
|
|
173 |
|
|
INTEGER limbas, limhau ! les couches a ajuster |
174 |
|
|
! cc PARAMETER (limbas=klev-3, limhau=klev) |
175 |
|
|
! ym PARAMETER (limbas=1, limhau=klev) |
176 |
|
|
|
177 |
|
|
LOGICAL mixq |
178 |
|
|
! cc PARAMETER (mixq=.TRUE.) |
179 |
|
|
PARAMETER (mixq=.FALSE.) |
180 |
|
|
|
181 |
|
|
REAL zh(klon, klev) |
182 |
|
|
REAL zq(klon, klev) |
183 |
|
|
REAL zpk(klon, klev) |
184 |
|
|
REAL zpkdp(klon, klev) |
185 |
|
|
REAL hm, sm, qm |
186 |
|
|
LOGICAL modif(klon), down |
187 |
|
|
INTEGER i, k, k1, k2 |
188 |
|
|
|
189 |
|
|
! Initialisation: |
190 |
|
|
|
191 |
|
|
! ym |
192 |
|
|
limbas = 1 |
193 |
|
|
limhau = klev |
194 |
|
|
|
195 |
|
|
DO k = 1, klev |
196 |
|
|
DO i = 1, klon |
197 |
|
|
d_t(i, k) = 0.0 |
198 |
|
|
d_q(i, k) = 0.0 |
199 |
|
|
END DO |
200 |
|
|
END DO |
201 |
|
|
! ------------------------------------- detection des profils a modifier |
202 |
|
|
DO k = limbas, limhau |
203 |
|
|
DO i = 1, klon |
204 |
|
|
zpk(i, k) = pplay(i, k)**rkappa |
205 |
|
|
zh(i, k) = rcpd*t(i, k)/zpk(i, k) |
206 |
|
|
zq(i, k) = q(i, k) |
207 |
|
|
END DO |
208 |
|
|
END DO |
209 |
|
|
|
210 |
|
|
DO k = limbas, limhau |
211 |
|
|
DO i = 1, klon |
212 |
|
|
zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1)) |
213 |
|
|
END DO |
214 |
|
|
END DO |
215 |
|
|
|
216 |
|
|
DO i = 1, klon |
217 |
|
|
modif(i) = .FALSE. |
218 |
|
|
END DO |
219 |
|
|
DO k = limbas + 1, limhau |
220 |
|
|
DO i = 1, klon |
221 |
|
|
IF (.NOT. modif(i)) THEN |
222 |
|
|
IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE. |
223 |
|
|
END IF |
224 |
|
|
END DO |
225 |
|
|
END DO |
226 |
|
|
! ------------------------------------- correction des profils instables |
227 |
|
|
DO i = 1, klon |
228 |
|
|
IF (modif(i)) THEN |
229 |
|
|
k2 = limbas |
230 |
|
|
8000 CONTINUE |
231 |
|
|
k2 = k2 + 1 |
232 |
|
|
IF (k2>limhau) GO TO 8001 |
233 |
|
|
IF (zh(i,k2)<zh(i,k2-1)) THEN |
234 |
|
|
k1 = k2 - 1 |
235 |
|
|
k = k1 |
236 |
|
|
sm = zpkdp(i, k2) |
237 |
|
|
hm = zh(i, k2) |
238 |
|
|
qm = zq(i, k2) |
239 |
|
|
8020 CONTINUE |
240 |
|
|
sm = sm + zpkdp(i, k) |
241 |
|
|
hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm |
242 |
|
|
qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm |
243 |
|
|
down = .FALSE. |
244 |
|
|
IF (k1/=limbas) THEN |
245 |
|
|
IF (hm<zh(i,k1-1)) down = .TRUE. |
246 |
|
|
END IF |
247 |
|
|
IF (down) THEN |
248 |
|
|
k1 = k1 - 1 |
249 |
|
|
k = k1 |
250 |
|
|
ELSE |
251 |
|
|
IF ((k2==limhau)) GO TO 8021 |
252 |
|
|
IF ((zh(i,k2+1)>=hm)) GO TO 8021 |
253 |
|
|
k2 = k2 + 1 |
254 |
|
|
k = k2 |
255 |
|
|
END IF |
256 |
|
|
GO TO 8020 |
257 |
|
|
8021 CONTINUE |
258 |
|
|
! ------------ nouveau profil : constant (valeur moyenne) |
259 |
|
|
DO k = k1, k2 |
260 |
|
|
zh(i, k) = hm |
261 |
|
|
zq(i, k) = qm |
262 |
|
|
END DO |
263 |
|
|
k2 = k2 + 1 |
264 |
|
|
END IF |
265 |
|
|
GO TO 8000 |
266 |
|
|
8001 CONTINUE |
267 |
|
|
END IF |
268 |
|
|
END DO |
269 |
|
|
|
270 |
|
|
DO k = limbas, limhau |
271 |
|
|
DO i = 1, klon |
272 |
|
|
d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k) |
273 |
|
|
d_q(i, k) = zq(i, k) - q(i, k) |
274 |
|
|
END DO |
275 |
|
|
END DO |
276 |
|
|
|
277 |
|
|
IF (limbas>1) THEN |
278 |
|
|
DO k = 1, limbas - 1 |
279 |
|
|
DO i = 1, klon |
280 |
|
|
d_t(i, k) = 0.0 |
281 |
|
|
d_q(i, k) = 0.0 |
282 |
|
|
END DO |
283 |
|
|
END DO |
284 |
|
|
END IF |
285 |
|
|
|
286 |
|
|
IF (limhau<klev) THEN |
287 |
|
|
DO k = limhau + 1, klev |
288 |
|
|
DO i = 1, klon |
289 |
|
|
d_t(i, k) = 0.0 |
290 |
|
|
d_q(i, k) = 0.0 |
291 |
|
|
END DO |
292 |
|
|
END DO |
293 |
|
|
END IF |
294 |
|
|
|
295 |
|
|
IF (.NOT. mixq) THEN |
296 |
|
|
DO k = 1, klev |
297 |
|
|
DO i = 1, klon |
298 |
|
|
d_q(i, k) = 0.0 |
299 |
|
|
END DO |
300 |
|
|
END DO |
301 |
|
|
END IF |
302 |
|
|
|
303 |
|
|
RETURN |
304 |
|
|
END SUBROUTINE ajsec_convv2 |
305 |
|
|
SUBROUTINE ajsec_old(paprs, pplay, t, d_t) |
306 |
|
|
USE dimphy |
307 |
|
|
IMPLICIT NONE |
308 |
|
|
! ====================================================================== |
309 |
|
|
! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 |
310 |
|
|
! Objet: ajustement sec (adaptation du GCM du LMD) |
311 |
|
|
! ====================================================================== |
312 |
|
|
! Arguments: |
313 |
|
|
! t-------input-R- Temperature |
314 |
|
|
|
315 |
|
|
! d_t-----output-R-Incrementation de la temperature |
316 |
|
|
! ====================================================================== |
317 |
|
|
include "YOMCST.h" |
318 |
|
|
REAL paprs(klon, klev+1), pplay(klon, klev) |
319 |
|
|
REAL t(klon, klev) |
320 |
|
|
REAL d_t(klon, klev) |
321 |
|
|
|
322 |
|
|
REAL local_h(klon, klev) |
323 |
|
|
REAL hm, sm |
324 |
|
|
LOGICAL modif(klon), down |
325 |
|
|
INTEGER i, l, l1, l2 |
326 |
|
|
! ------------------------------------- detection des profils a modifier |
327 |
|
|
DO i = 1, klon |
328 |
|
|
modif(i) = .FALSE. |
329 |
|
|
END DO |
330 |
|
|
|
331 |
|
|
DO l = 1, klev |
332 |
|
|
DO i = 1, klon |
333 |
|
|
local_h(i, l) = rcpd*t(i, l)/(pplay(i,l)**rkappa) |
334 |
|
|
END DO |
335 |
|
|
END DO |
336 |
|
|
|
337 |
|
|
DO l = 2, klev |
338 |
|
|
DO i = 1, klon |
339 |
|
|
IF (local_h(i,l)<local_h(i,l-1)) THEN |
340 |
|
|
modif(i) = .TRUE. |
341 |
|
|
ELSE |
342 |
|
|
modif(i) = modif(i) |
343 |
|
|
END IF |
344 |
|
|
END DO |
345 |
|
|
END DO |
346 |
|
|
! ------------------------------------- correction des profils instables |
347 |
|
|
DO i = 1, klon |
348 |
|
|
IF (modif(i)) THEN |
349 |
|
|
l2 = 1 |
350 |
|
|
8000 CONTINUE |
351 |
|
|
l2 = l2 + 1 |
352 |
|
|
IF (l2>klev) GO TO 8001 |
353 |
|
|
IF (local_h(i,l2)<local_h(i,l2-1)) THEN |
354 |
|
|
l1 = l2 - 1 |
355 |
|
|
l = l1 |
356 |
|
|
sm = pplay(i, l2)**rkappa*(paprs(i,l2)-paprs(i,l2+1)) |
357 |
|
|
hm = local_h(i, l2) |
358 |
|
|
8020 CONTINUE |
359 |
|
|
sm = sm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1)) |
360 |
|
|
hm = hm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))*(local_h(i,l) & |
361 |
|
|
-hm)/sm |
362 |
|
|
down = .FALSE. |
363 |
|
|
IF (l1/=1) THEN |
364 |
|
|
IF (hm<local_h(i,l1-1)) THEN |
365 |
|
|
down = .TRUE. |
366 |
|
|
END IF |
367 |
|
|
END IF |
368 |
|
|
IF (down) THEN |
369 |
|
|
l1 = l1 - 1 |
370 |
|
|
l = l1 |
371 |
|
|
ELSE |
372 |
|
|
IF ((l2==klev)) GO TO 8021 |
373 |
|
|
IF ((local_h(i,l2+1)>=hm)) GO TO 8021 |
374 |
|
|
l2 = l2 + 1 |
375 |
|
|
l = l2 |
376 |
|
|
END IF |
377 |
|
|
GO TO 8020 |
378 |
|
|
8021 CONTINUE |
379 |
|
|
! ------------ nouveau profil : constant (valeur moyenne) |
380 |
|
|
DO l = l1, l2 |
381 |
|
|
local_h(i, l) = hm |
382 |
|
|
END DO |
383 |
|
|
l2 = l2 + 1 |
384 |
|
|
END IF |
385 |
|
|
GO TO 8000 |
386 |
|
|
8001 CONTINUE |
387 |
|
|
END IF |
388 |
|
|
END DO |
389 |
|
|
|
390 |
|
|
DO l = 1, klev |
391 |
|
|
DO i = 1, klon |
392 |
|
|
d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l) |
393 |
|
|
END DO |
394 |
|
|
END DO |
395 |
|
|
|
396 |
|
|
RETURN |
397 |
|
|
END SUBROUTINE ajsec_old |