source: LMDZ6/trunk/libf/phylmd/ajsec.f90 @ 5274

Last change on this file since 5274 was 5274, checked in by abarral, 9 hours ago

Replace yomcst.h by existing module
  • 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: 11.5 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, ONLY: RPI, RCLUM, RHPLA, RKBOL, RNAVO                   &
7          , RDAY, REA, REPSM, RSIYEA, RSIDAY, ROMEGA                  &
8          , R_ecc, R_peri, R_incl                                      &
9          , RA, RG, R1SA                                         &
10          , RSIGMA                                                     &
11          , R, RMD, RMV, RD, RV, RCPD                    &
12          , RMO3, RMCO2, RMC, RMCH4, RMN2O, RMCFC11, RMCFC12        &
13          , RCPV, RCVD, RCVV, RKAPPA, RETV, eps_w                    &
14          , RCW, RCS                                                 &
15          , RLVTT, RLSTT, RLMLT, RTT, RATM                           &
16          , RESTT, RALPW, RBETW, RGAMW, RALPS, RBETS, RGAMS            &
17          , RALPD, RBETD, RGAMD
18IMPLICIT NONE
19  ! ======================================================================
20  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
21  ! Objet: ajustement sec (adaptation du GCM du LMD)
22  ! ======================================================================
23  ! Arguments:
24  ! t-------input-R- Temperature
25
26  ! d_t-----output-R-Incrementation de la temperature
27  ! ======================================================================
28
29  REAL paprs(klon, klev+1), pplay(klon, klev)
30  REAL t(klon, klev), q(klon, klev)
31  REAL d_t(klon, klev), d_q(klon, klev)
32
33  INTEGER limbas(klon), limhau ! les couches a ajuster
34
35  LOGICAL mixq
36  ! cc      PARAMETER (mixq=.TRUE.)
37  PARAMETER (mixq=.FALSE.)
38
39  REAL zh(klon, klev)
40  REAL zho(klon, klev)
41  REAL zq(klon, klev)
42  REAL zpk(klon, klev)
43  REAL zpkdp(klon, klev)
44  REAL hm, sm, qm
45  LOGICAL modif(klon), down
46  INTEGER i, k, k1, k2
47
48  ! Initialisation:
49
50  ! ym
51  limhau = klev
52
53  DO k = 1, klev
54    DO i = 1, klon
55      d_t(i, k) = 0.0
56      d_q(i, k) = 0.0
57    END DO
58  END DO
59  ! ------------------------------------- detection des profils a modifier
60  DO k = 1, limhau
61    DO i = 1, klon
62      zpk(i, k) = pplay(i, k)**rkappa
63      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
64      zho(i, k) = zh(i, k)
65      zq(i, k) = q(i, k)
66    END DO
67  END DO
68
69  DO k = 1, limhau
70    DO i = 1, klon
71      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
72    END DO
73  END DO
74
75  DO i = 1, klon
76    modif(i) = .FALSE.
77  END DO
78  DO k = 2, limhau
79    DO i = 1, klon
80      IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN
81        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
82      END IF
83    END DO
84  END DO
85  ! ------------------------------------- correction des profils instables
86  DO i = 1, klon
87    IF (modif(i)) THEN
88      k2 = limbas(i)
898000  CONTINUE
90      k2 = k2 + 1
91      IF (k2>limhau) GO TO 8001
92      IF (zh(i,k2)<zh(i,k2-1)) THEN
93        k1 = k2 - 1
94        k = k1
95        sm = zpkdp(i, k2)
96        hm = zh(i, k2)
97        qm = zq(i, k2)
988020    CONTINUE
99        sm = sm + zpkdp(i, k)
100        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
101        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
102        down = .FALSE.
103        IF (k1/=limbas(i)) THEN
104          IF (hm<zh(i,k1-1)) down = .TRUE.
105        END IF
106        IF (down) THEN
107          k1 = k1 - 1
108          k = k1
109        ELSE
110          IF ((k2==limhau)) GO TO 8021
111          IF ((zh(i,k2+1)>=hm)) GO TO 8021
112          k2 = k2 + 1
113          k = k2
114        END IF
115        GO TO 8020
1168021    CONTINUE
117        ! ------------ nouveau profil : constant (valeur moyenne)
118        DO k = k1, k2
119          zh(i, k) = hm
120          zq(i, k) = qm
121        END DO
122        k2 = k2 + 1
123      END IF
124      GO TO 8000
1258001  CONTINUE
126    END IF
127  END DO
128
129  DO k = 1, limhau
130    DO i = 1, klon
131      d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd
132      d_q(i, k) = zq(i, k) - q(i, k)
133    END DO
134  END DO
135
136  ! FH : les d_q et d_t sont maintenant calcules de facon a valoir
137  ! effectivement 0. si on ne fait rien.
138
139  ! IF (limbas.GT.1) THEN
140  ! DO k = 1, limbas-1
141  ! DO i = 1, klon
142  ! d_t(i,k) = 0.0
143  ! d_q(i,k) = 0.0
144  ! ENDDO
145  ! ENDDO
146  ! ENDIF
147
148  ! IF (limhau.LT.klev) THEN
149  ! DO k = limhau+1, klev
150  ! DO i = 1, klon
151  ! d_t(i,k) = 0.0
152  ! d_q(i,k) = 0.0
153  ! ENDDO
154  ! ENDDO
155  ! ENDIF
156
157  IF (.NOT. mixq) THEN
158    DO k = 1, klev
159      DO i = 1, klon
160        d_q(i, k) = 0.0
161      END DO
162    END DO
163  END IF
164
165  RETURN
166END SUBROUTINE ajsec
167
168SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q)
169  USE dimphy
170  USE yomcst_mod_h, ONLY: RPI, RCLUM, RHPLA, RKBOL, RNAVO                   &
171          , RDAY, REA, REPSM, RSIYEA, RSIDAY, ROMEGA                  &
172          , R_ecc, R_peri, R_incl                                      &
173          , RA, RG, R1SA                                         &
174          , RSIGMA                                                     &
175          , R, RMD, RMV, RD, RV, RCPD                    &
176          , RMO3, RMCO2, RMC, RMCH4, RMN2O, RMCFC11, RMCFC12        &
177          , RCPV, RCVD, RCVV, RKAPPA, RETV, eps_w                    &
178          , RCW, RCS                                                 &
179          , RLVTT, RLSTT, RLMLT, RTT, RATM                           &
180          , RESTT, RALPW, RBETW, RGAMW, RALPS, RBETS, RGAMS            &
181          , RALPD, RBETD, RGAMD
182IMPLICIT NONE
183  ! ======================================================================
184  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
185  ! Objet: ajustement sec (adaptation du GCM du LMD)
186  ! ======================================================================
187  ! Arguments:
188  ! t-------input-R- Temperature
189
190  ! d_t-----output-R-Incrementation de la temperature
191  ! ======================================================================
192
193  REAL paprs(klon, klev+1), pplay(klon, klev)
194  REAL t(klon, klev), q(klon, klev)
195  REAL d_t(klon, klev), d_q(klon, klev)
196
197  INTEGER limbas, limhau ! les couches a ajuster
198  ! cc      PARAMETER (limbas=klev-3, limhau=klev)
199  ! ym      PARAMETER (limbas=1, limhau=klev)
200
201  LOGICAL mixq
202  ! cc      PARAMETER (mixq=.TRUE.)
203  PARAMETER (mixq=.FALSE.)
204
205  REAL zh(klon, klev)
206  REAL zq(klon, klev)
207  REAL zpk(klon, klev)
208  REAL zpkdp(klon, klev)
209  REAL hm, sm, qm
210  LOGICAL modif(klon), down
211  INTEGER i, k, k1, k2
212
213  ! Initialisation:
214
215  ! ym
216  limbas = 1
217  limhau = klev
218
219  DO k = 1, klev
220    DO i = 1, klon
221      d_t(i, k) = 0.0
222      d_q(i, k) = 0.0
223    END DO
224  END DO
225  ! ------------------------------------- detection des profils a modifier
226  DO k = limbas, limhau
227    DO i = 1, klon
228      zpk(i, k) = pplay(i, k)**rkappa
229      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
230      zq(i, k) = q(i, k)
231    END DO
232  END DO
233
234  DO k = limbas, limhau
235    DO i = 1, klon
236      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
237    END DO
238  END DO
239
240  DO i = 1, klon
241    modif(i) = .FALSE.
242  END DO
243  DO k = limbas + 1, limhau
244    DO i = 1, klon
245      IF (.NOT. modif(i)) THEN
246        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
247      END IF
248    END DO
249  END DO
250  ! ------------------------------------- correction des profils instables
251  DO i = 1, klon
252    IF (modif(i)) THEN
253      k2 = limbas
2548000  CONTINUE
255      k2 = k2 + 1
256      IF (k2>limhau) GO TO 8001
257      IF (zh(i,k2)<zh(i,k2-1)) THEN
258        k1 = k2 - 1
259        k = k1
260        sm = zpkdp(i, k2)
261        hm = zh(i, k2)
262        qm = zq(i, k2)
2638020    CONTINUE
264        sm = sm + zpkdp(i, k)
265        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
266        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
267        down = .FALSE.
268        IF (k1/=limbas) THEN
269          IF (hm<zh(i,k1-1)) down = .TRUE.
270        END IF
271        IF (down) THEN
272          k1 = k1 - 1
273          k = k1
274        ELSE
275          IF ((k2==limhau)) GO TO 8021
276          IF ((zh(i,k2+1)>=hm)) GO TO 8021
277          k2 = k2 + 1
278          k = k2
279        END IF
280        GO TO 8020
2818021    CONTINUE
282        ! ------------ nouveau profil : constant (valeur moyenne)
283        DO k = k1, k2
284          zh(i, k) = hm
285          zq(i, k) = qm
286        END DO
287        k2 = k2 + 1
288      END IF
289      GO TO 8000
2908001  CONTINUE
291    END IF
292  END DO
293
294  DO k = limbas, limhau
295    DO i = 1, klon
296      d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k)
297      d_q(i, k) = zq(i, k) - q(i, k)
298    END DO
299  END DO
300
301  IF (limbas>1) THEN
302    DO k = 1, limbas - 1
303      DO i = 1, klon
304        d_t(i, k) = 0.0
305        d_q(i, k) = 0.0
306      END DO
307    END DO
308  END IF
309
310  IF (limhau<klev) THEN
311    DO k = limhau + 1, klev
312      DO i = 1, klon
313        d_t(i, k) = 0.0
314        d_q(i, k) = 0.0
315      END DO
316    END DO
317  END IF
318
319  IF (.NOT. mixq) THEN
320    DO k = 1, klev
321      DO i = 1, klon
322        d_q(i, k) = 0.0
323      END DO
324    END DO
325  END IF
326
327  RETURN
328END SUBROUTINE ajsec_convv2
329SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
330  USE dimphy
331  USE yomcst_mod_h, ONLY: RPI, RCLUM, RHPLA, RKBOL, RNAVO                   &
332          , RDAY, REA, REPSM, RSIYEA, RSIDAY, ROMEGA                  &
333          , R_ecc, R_peri, R_incl                                      &
334          , RA, RG, R1SA                                         &
335          , RSIGMA                                                     &
336          , R, RMD, RMV, RD, RV, RCPD                    &
337          , RMO3, RMCO2, RMC, RMCH4, RMN2O, RMCFC11, RMCFC12        &
338          , RCPV, RCVD, RCVV, RKAPPA, RETV, eps_w                    &
339          , RCW, RCS                                                 &
340          , RLVTT, RLSTT, RLMLT, RTT, RATM                           &
341          , RESTT, RALPW, RBETW, RGAMW, RALPS, RBETS, RGAMS            &
342          , RALPD, RBETD, RGAMD
343IMPLICIT NONE
344  ! ======================================================================
345  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
346  ! Objet: ajustement sec (adaptation du GCM du LMD)
347  ! ======================================================================
348  ! Arguments:
349  ! t-------input-R- Temperature
350
351  ! d_t-----output-R-Incrementation de la temperature
352  ! ======================================================================
353
354  REAL paprs(klon, klev+1), pplay(klon, klev)
355  REAL t(klon, klev)
356  REAL d_t(klon, klev)
357
358  REAL local_h(klon, klev)
359  REAL hm, sm
360  LOGICAL modif(klon), down
361  INTEGER i, l, l1, l2
362  ! ------------------------------------- detection des profils a modifier
363  DO i = 1, klon
364    modif(i) = .FALSE.
365  END DO
366
367  DO l = 1, klev
368    DO i = 1, klon
369      local_h(i, l) = rcpd*t(i, l)/(pplay(i,l)**rkappa)
370    END DO
371  END DO
372
373  DO l = 2, klev
374    DO i = 1, klon
375      IF (local_h(i,l)<local_h(i,l-1)) THEN
376        modif(i) = .TRUE.
377      ELSE
378        modif(i) = modif(i)
379      END IF
380    END DO
381  END DO
382  ! ------------------------------------- correction des profils instables
383  DO i = 1, klon
384    IF (modif(i)) THEN
385      l2 = 1
3868000  CONTINUE
387      l2 = l2 + 1
388      IF (l2>klev) GO TO 8001
389      IF (local_h(i,l2)<local_h(i,l2-1)) THEN
390        l1 = l2 - 1
391        l = l1
392        sm = pplay(i, l2)**rkappa*(paprs(i,l2)-paprs(i,l2+1))
393        hm = local_h(i, l2)
3948020    CONTINUE
395        sm = sm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))
396        hm = hm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))*(local_h(i,l) &
397          -hm)/sm
398        down = .FALSE.
399        IF (l1/=1) THEN
400          IF (hm<local_h(i,l1-1)) THEN
401            down = .TRUE.
402          END IF
403        END IF
404        IF (down) THEN
405          l1 = l1 - 1
406          l = l1
407        ELSE
408          IF ((l2==klev)) GO TO 8021
409          IF ((local_h(i,l2+1)>=hm)) GO TO 8021
410          l2 = l2 + 1
411          l = l2
412        END IF
413        GO TO 8020
4148021    CONTINUE
415        ! ------------ nouveau profil : constant (valeur moyenne)
416        DO l = l1, l2
417          local_h(i, l) = hm
418        END DO
419        l2 = l2 + 1
420      END IF
421      GO TO 8000
4228001  CONTINUE
423    END IF
424  END DO
425
426  DO l = 1, klev
427    DO i = 1, klon
428      d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l)
429    END DO
430  END DO
431
432  RETURN
433END SUBROUTINE ajsec_old
Note: See TracBrowser for help on using the repository browser.