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

Last change on this file since 5119 was 5105, checked in by abarral, 4 months ago

Replace 1DUTILS.h by module lmdz_1dutils.f90
Replace 1DConv.h by module lmdz_old_1dconv.f90 (it's only used by old_* files)
Convert *.F to *.f90
Fix gradsdef.h formatting
Remove unnecessary "RETURN" at the end of functions/subroutines
  • 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
RevLine 
[1992]1
[524]2! $Header$
[1992]3
4SUBROUTINE 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)
778000  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)
868020    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
1048021    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
1138001  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
[878]147      DO i = 1, klon
[1992]148        d_q(i, k) = 0.0
149      END DO
150    END DO
151  END IF
152
[5105]153
[1992]154END SUBROUTINE ajsec
155
156SUBROUTINE 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
2308000  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)
2398020    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
2578021    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
2668001  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
[878]279      DO i = 1, klon
[1992]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
[878]288      DO i = 1, klon
[1992]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
[878]297      DO i = 1, klon
[1992]298        d_q(i, k) = 0.0
299      END DO
300    END DO
301  END IF
[878]302
[5105]303
[1992]304END SUBROUTINE ajsec_convv2
305SUBROUTINE 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
3508000  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)
3588020    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
3788021    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
3868001  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
[5105]396
[1992]397END SUBROUTINE ajsec_old
Note: See TracBrowser for help on using the repository browser.