source: LMDZ5/branches/LMDZ5_SPLA/libf/phylmd/ajsec.F90 @ 2404

Last change on this file since 2404 was 1992, checked in by lguez, 11 years ago

Converted to free source form files in libf/phylmd which were still in
fixed source form. The conversion was done using the polish mode of
the NAG Fortran Compiler.

In addition to converting to free source form, the processing of the
files also:

-- indented the code (including comments);

-- set Fortran keywords to uppercase, and set all other identifiers
to lower case;

-- added qualifiers to end statements (for example "end subroutine
conflx", instead of "end");

-- changed the terminating statements of all DO loops so that each
loop ends with an ENDDO statement (instead of a labeled continue).

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