source: LMDZ6/branches/contrails/libf/phylmd/ajsec.f90 @ 5440

Last change on this file since 5440 was 5285, checked in by abarral, 2 months ago

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