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