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

Last change on this file since 5157 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
RevLine 
[524]1! $Header$
[1992]2
3SUBROUTINE ajsec(paprs, pplay, t, q, limbas, d_t, d_q)
4  USE dimphy
[5144]5  USE lmdz_yomcst
6
[1992]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  ! ======================================================================
[5144]17  REAL paprs(klon, klev + 1), pplay(klon, klev)
[1992]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.)
[5144]25  PARAMETER (mixq = .FALSE.)
[1992]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
[5144]51      zh(i, k) = rcpd * t(i, k) / zpk(i, k)
[1992]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
[5144]59      zpkdp(i, k) = zpk(i, k) * (paprs(i, k) - paprs(i, k + 1))
[1992]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
[5144]68      IF (.NOT. modif(i) .AND. k - 1>limbas(i)) THEN
69        IF (zh(i, k)<zh(i, k - 1)) modif(i) = .TRUE.
[1992]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)
[5144]77      8000  CONTINUE
[1992]78      k2 = k2 + 1
79      IF (k2>limhau) GO TO 8001
[5144]80      IF (zh(i, k2)<zh(i, k2 - 1)) THEN
[1992]81        k1 = k2 - 1
82        k = k1
83        sm = zpkdp(i, k2)
84        hm = zh(i, k2)
85        qm = zq(i, k2)
[5144]86        8020    CONTINUE
[1992]87        sm = sm + zpkdp(i, k)
[5144]88        hm = hm + zpkdp(i, k) * (zh(i, k) - hm) / sm
89        qm = qm + zpkdp(i, k) * (zq(i, k) - qm) / sm
[1992]90        down = .FALSE.
91        IF (k1/=limbas(i)) THEN
[5144]92          IF (hm<zh(i, k1 - 1)) down = .TRUE.
[1992]93        END IF
94        IF (down) THEN
95          k1 = k1 - 1
96          k = k1
97        ELSE
98          IF ((k2==limhau)) GO TO 8021
[5144]99          IF ((zh(i, k2 + 1)>=hm)) GO TO 8021
[1992]100          k2 = k2 + 1
101          k = k2
102        END IF
103        GO TO 8020
[5144]104        8021    CONTINUE
[1992]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
[5144]113      8001  CONTINUE
[1992]114    END IF
115  END DO
116
117  DO k = 1, limhau
118    DO i = 1, klon
[5144]119      d_t(i, k) = (zh(i, k) - zho(i, k)) * zpk(i, k) / rcpd
[1992]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
153END SUBROUTINE ajsec
154
155SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q)
156  USE dimphy
[5144]157  USE lmdz_yomcst
158
[1992]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  ! ======================================================================
[5144]169  REAL paprs(klon, klev + 1), pplay(klon, klev)
[1992]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.)
[5144]179  PARAMETER (mixq = .FALSE.)
[1992]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
[5144]205      zh(i, k) = rcpd * t(i, k) / zpk(i, k)
[1992]206      zq(i, k) = q(i, k)
207    END DO
208  END DO
209
210  DO k = limbas, limhau
211    DO i = 1, klon
[5144]212      zpkdp(i, k) = zpk(i, k) * (paprs(i, k) - paprs(i, k + 1))
[1992]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
[5144]222        IF (zh(i, k)<zh(i, k - 1)) modif(i) = .TRUE.
[1992]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
[5144]230      8000  CONTINUE
[1992]231      k2 = k2 + 1
232      IF (k2>limhau) GO TO 8001
[5144]233      IF (zh(i, k2)<zh(i, k2 - 1)) THEN
[1992]234        k1 = k2 - 1
235        k = k1
236        sm = zpkdp(i, k2)
237        hm = zh(i, k2)
238        qm = zq(i, k2)
[5144]239        8020    CONTINUE
[1992]240        sm = sm + zpkdp(i, k)
[5144]241        hm = hm + zpkdp(i, k) * (zh(i, k) - hm) / sm
242        qm = qm + zpkdp(i, k) * (zq(i, k) - qm) / sm
[1992]243        down = .FALSE.
244        IF (k1/=limbas) THEN
[5144]245          IF (hm<zh(i, k1 - 1)) down = .TRUE.
[1992]246        END IF
247        IF (down) THEN
248          k1 = k1 - 1
249          k = k1
250        ELSE
251          IF ((k2==limhau)) GO TO 8021
[5144]252          IF ((zh(i, k2 + 1)>=hm)) GO TO 8021
[1992]253          k2 = k2 + 1
254          k = k2
255        END IF
256        GO TO 8020
[5144]257        8021    CONTINUE
[1992]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
[5144]266      8001  CONTINUE
[1992]267    END IF
268  END DO
269
270  DO k = limbas, limhau
271    DO i = 1, klon
[5144]272      d_t(i, k) = zh(i, k) * zpk(i, k) / rcpd - t(i, k)
[1992]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
[1992]303END SUBROUTINE ajsec_convv2
304SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
305  USE dimphy
[5144]306  USE lmdz_yomcst
307
[1992]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  ! ======================================================================
[5144]318  REAL paprs(klon, klev + 1), pplay(klon, klev)
[1992]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
[5144]333      local_h(i, l) = rcpd * t(i, l) / (pplay(i, l)**rkappa)
[1992]334    END DO
335  END DO
336
337  DO l = 2, klev
338    DO i = 1, klon
[5144]339      IF (local_h(i, l)<local_h(i, l - 1)) THEN
[1992]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
[5144]350      8000  CONTINUE
[1992]351      l2 = l2 + 1
352      IF (l2>klev) GO TO 8001
[5144]353      IF (local_h(i, l2)<local_h(i, l2 - 1)) THEN
[1992]354        l1 = l2 - 1
355        l = l1
[5144]356        sm = pplay(i, l2)**rkappa * (paprs(i, l2) - paprs(i, l2 + 1))
[1992]357        hm = local_h(i, l2)
[5144]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
[1992]362        down = .FALSE.
363        IF (l1/=1) THEN
[5144]364          IF (hm<local_h(i, l1 - 1)) THEN
[1992]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
[5144]373          IF ((local_h(i, l2 + 1)>=hm)) GO TO 8021
[1992]374          l2 = l2 + 1
375          l = l2
376        END IF
377        GO TO 8020
[5144]378        8021    CONTINUE
[1992]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
[5144]386      8001  CONTINUE
[1992]387    END IF
388  END DO
389
390  DO l = 1, klev
391    DO i = 1, klon
[5144]392      d_t(i, l) = local_h(i, l) * (pplay(i, l)**rkappa) / rcpd - t(i, l)
[1992]393    END DO
394  END DO
395
396END SUBROUTINE ajsec_old
Note: See TracBrowser for help on using the repository browser.