LMDZ
ajsec.F90
Go to the documentation of this file.
1 
2 ! $Id: ajsec.F90 2346 2015-08-21 15:13:46Z emillour $
3 
4 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  REAL zh(klon, klev)
28  REAL zho(klon, klev)
29  REAL zq(klon, klev)
30  REAL zpk(klon, klev)
31  REAL zpkdp(klon, klev)
32  REAL hm, sm, qm
33  LOGICAL modif(klon), down
34  INTEGER i, k, k1, k2
35 
36  ! Initialisation:
37 
38  ! ym
39  limhau = klev
40 
41  DO k = 1, klev
42  DO i = 1, klon
43  d_t(i, k) = 0.0
44  d_q(i, k) = 0.0
45  END DO
46  END DO
47  ! ------------------------------------- detection des profils a modifier
48  DO k = 1, limhau
49  DO i = 1, klon
50  zpk(i, k) = pplay(i, k)**rkappa
51  zh(i, k) = rcpd*t(i, k)/zpk(i, k)
52  zho(i, k) = zh(i, k)
53  zq(i, k) = q(i, k)
54  END DO
55  END DO
56 
57  DO k = 1, limhau
58  DO i = 1, klon
59  zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
60  END DO
61  END DO
62 
63  DO i = 1, klon
64  modif(i) = .false.
65  END DO
66  DO k = 2, limhau
67  DO i = 1, klon
68  IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN
69  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  DO i = 1, klon
75  IF (modif(i)) THEN
76  k2 = limbas(i)
77 8000 CONTINUE
78  k2 = k2 + 1
79  IF (k2>limhau) GO TO 8001
80  IF (zh(i,k2)<zh(i,k2-1)) THEN
81  k1 = k2 - 1
82  k = k1
83  sm = zpkdp(i, k2)
84  hm = zh(i, k2)
85  qm = zq(i, k2)
86 8020 CONTINUE
87  sm = sm + zpkdp(i, k)
88  hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
89  qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
90  down = .false.
91  IF (k1/=limbas(i)) THEN
92  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  IF ((k2==limhau)) GO TO 8021
99  IF ((zh(i,k2+1)>=hm)) GO TO 8021
100  k2 = k2 + 1
101  k = k2
102  END IF
103  GO TO 8020
104 8021 CONTINUE
105  ! ------------ nouveau profil : constant (valeur moyenne)
106  DO k = k1, k2
107  zh(i, k) = hm
108  zq(i, k) = qm
109  END DO
110  k2 = k2 + 1
111  END IF
112  GO TO 8000
113 8001 CONTINUE
114  END IF
115  END DO
116 
117  DO k = 1, limhau
118  DO i = 1, klon
119  d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd
120  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  DO k = 1, klev
147  DO i = 1, klon
148  d_q(i, k) = 0.0
149  END DO
150  END DO
151  END IF
152 
153  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
ajsec_old
subroutine ajsec_old(paprs, pplay, t, d_t)
Definition: ajsec.F90:306
ajsec
subroutine ajsec(paprs, pplay, t, q, limbas, d_t, d_q)
Definition: ajsec.F90:5
dimphy::klon
integer, save klon
Definition: dimphy.F90:3
dimphy::klev
integer, save klev
Definition: dimphy.F90:7
false
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL false
Definition: calcul_STDlev.h:26
ajsec_convv2
subroutine ajsec_convv2(paprs, pplay, t, q, d_t, d_q)
Definition: ajsec.F90:157
parameter
!$Header!integer nvarmx parameter(nfmx=10, imx=200, jmx=150, lmx=200, nvarmx=1000) real xd(imx
true
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL ulevSTD CALL &zphi philevSTD CALL &zx_rh rhlevSTD!DO klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon du jour ou toutes les read_climoz CALL true
Definition: calcul_STDlev.h:139
dimphy
Definition: dimphy.F90:1