source: LMDZ6/branches/Amaury_dev/libf/phylmd/ajsec.F90 @ 5159

Last change on this file since 5159 was 5144, checked in by abarral, 3 months ago

Put YOMCST.h into modules
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.4 KB
Line 
1! $Header$
2
3SUBROUTINE ajsec(paprs, pplay, t, q, limbas, d_t, d_q)
4  USE dimphy
5  USE lmdz_yomcst
6
7  IMPLICIT NONE
8  ! ======================================================================
9  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
10  ! Objet: ajustement sec (adaptation du GCM du LMD)
11  ! ======================================================================
12  ! Arguments:
13  ! t-------input-R- Temperature
14
15  ! d_t-----output-R-Incrementation de la temperature
16  ! ======================================================================
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
153END SUBROUTINE ajsec
154
155SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q)
156  USE dimphy
157  USE lmdz_yomcst
158
159  IMPLICIT NONE
160  ! ======================================================================
161  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
162  ! Objet: ajustement sec (adaptation du GCM du LMD)
163  ! ======================================================================
164  ! Arguments:
165  ! t-------input-R- Temperature
166
167  ! d_t-----output-R-Incrementation de la temperature
168  ! ======================================================================
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
303END SUBROUTINE ajsec_convv2
304SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
305  USE dimphy
306  USE lmdz_yomcst
307
308  IMPLICIT NONE
309  ! ======================================================================
310  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
311  ! Objet: ajustement sec (adaptation du GCM du LMD)
312  ! ======================================================================
313  ! Arguments:
314  ! t-------input-R- Temperature
315
316  ! d_t-----output-R-Incrementation de la temperature
317  ! ======================================================================
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
396END SUBROUTINE ajsec_old
Note: See TracBrowser for help on using the repository browser.