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

Last change on this file since 5821 was 5817, checked in by rkazeroni, 2 months ago

For GPU porting of ajsec and ajsec_convv2 routines:

Put routine into module (speeds up source-to-source transformation)
Add "horizontal" comment to specify possible names of horizontal variables

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