source: LMDZ6/branches/Portage_acc/libf/phylmd/ajsec.F90 @ 4166

Last change on this file since 4166 was 4166, checked in by Ehouarn Millour, 2 years ago

Update driver to test repeated calling of physics.
Add some intent() to ajsec.
And !$acc contructs for physiq arguments.
EM
  • 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: 10.5 KB
Line 
1
2! $Id: ajsec.F90 4166 2022-05-27 15:45:46Z emillour $
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,INTENT(IN) :: paprs(klon, klev+1), pplay(klon, klev)
18  REAL,INTENT(IN) :: t(klon, klev), q(klon, klev)
19  REAL,INTENT(OUT) :: d_t(klon, klev), d_q(klon, klev)
20
21  INTEGER,INTENT(IN) :: limbas(klon)
22  INTEGER :: limhau ! les couches a ajuster
23
24  LOGICAL mixq
25  ! cc      PARAMETER (mixq=.TRUE.)
26  PARAMETER (mixq=.FALSE.)
27
28  REAL zh(klon, klev)
29  REAL zho(klon, klev)
30  REAL zq(klon, klev)
31  REAL zpk(klon, klev)
32  REAL zpkdp(klon, klev)
33  REAL hm, sm, qm
34  LOGICAL modif(klon), down
35  INTEGER i, k, k1, k2
36
37  !$acc data create (zh, zho, zq,zpk,zpkdp,modif) &
38  !$acc &    copyin (paprs, pplay, t , q, limbas) &
39  !$acc &    copyout (d_t, d_q)                   &
40  !$acc &
41 
42  ! Initialisation:
43
44  ! ym
45  limhau = klev
46
47  !$acc kernels default(none) async
48  DO k = 1, klev
49    DO i = 1, klon
50      d_t(i, k) = 0.0
51      d_q(i, k) = 0.0
52    END DO
53  END DO
54  ! ------------------------------------- detection des profils a modifier
55  DO k = 1, limhau
56    DO i = 1, klon
57      zpk(i, k) = pplay(i, k)**rkappa
58      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
59      zho(i, k) = zh(i, k)
60      zq(i, k) = q(i, k)
61    END DO
62  END DO
63
64  DO k = 1, limhau
65    DO i = 1, klon
66      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
67    END DO
68  END DO
69
70  DO i = 1, klon
71    modif(i) = .FALSE.
72  END DO
73  DO k = 2, limhau
74    DO i = 1, klon
75      IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN
76        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
77      END IF
78    END DO
79  END DO
80  !$acc end kernels
81  ! ------------------------------------- correction des profils instables
82  !$acc kernels default(none) async
83  DO i = 1, klon
84    IF (modif(i)) THEN
85      k2 = limbas(i)
868000  CONTINUE
87      k2 = k2 + 1
88      IF (k2>limhau) GO TO 8001
89      IF (zh(i,k2)<zh(i,k2-1)) THEN
90        k1 = k2 - 1
91        k = k1
92        sm = zpkdp(i, k2)
93        hm = zh(i, k2)
94        qm = zq(i, k2)
958020    CONTINUE
96        sm = sm + zpkdp(i, k)
97        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
98        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
99        down = .FALSE.
100        IF (k1/=limbas(i)) THEN
101          IF (hm<zh(i,k1-1)) down = .TRUE.
102        END IF
103        IF (down) THEN
104          k1 = k1 - 1
105          k = k1
106        ELSE
107          IF ((k2==limhau)) GO TO 8021
108          IF ((zh(i,k2+1)>=hm)) GO TO 8021
109          k2 = k2 + 1
110          k = k2
111        END IF
112        GO TO 8020
1138021    CONTINUE
114        ! ------------ nouveau profil : constant (valeur moyenne)
115        DO k = k1, k2
116          zh(i, k) = hm
117          zq(i, k) = qm
118        END DO
119        k2 = k2 + 1
120      END IF
121      GO TO 8000
1228001  CONTINUE
123    END IF
124  END DO
125  !$acc end kernels
126
127  !$acc kernels default(none) async
128  DO k = 1, limhau
129    DO i = 1, klon
130      d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd
131      d_q(i, k) = zq(i, k) - q(i, k)
132    END DO
133  END DO
134  !$acc end kernels
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    !$acc kernels default(none) async
159    DO k = 1, klev
160      DO i = 1, klon
161        d_q(i, k) = 0.0
162      END DO
163    END DO
164    !$acc end kernels
165  END IF
166  !$acc end data
167
168  RETURN
169
170END SUBROUTINE ajsec
171
172SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q)
173  USE dimphy
174  IMPLICIT NONE
175  ! ======================================================================
176  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
177  ! Objet: ajustement sec (adaptation du GCM du LMD)
178  ! ======================================================================
179  ! Arguments:
180  ! t-------input-R- Temperature
181
182  ! d_t-----output-R-Incrementation de la temperature
183  ! ======================================================================
184  include "YOMCST.h"
185  REAL paprs(klon, klev+1), pplay(klon, klev)
186  REAL t(klon, klev), q(klon, klev)
187  REAL d_t(klon, klev), d_q(klon, klev)
188
189  INTEGER limbas, limhau ! les couches a ajuster
190  ! cc      PARAMETER (limbas=klev-3, limhau=klev)
191  ! ym      PARAMETER (limbas=1, limhau=klev)
192
193  LOGICAL mixq
194  ! cc      PARAMETER (mixq=.TRUE.)
195  PARAMETER (mixq=.FALSE.)
196
197  REAL zh(klon, klev)
198  REAL zq(klon, klev)
199  REAL zpk(klon, klev)
200  REAL zpkdp(klon, klev)
201  REAL hm, sm, qm
202  LOGICAL modif(klon), down
203  INTEGER i, k, k1, k2
204
205  !$acc data create (zh, zq, zpk, zpkdp, modif) &
206  !$acc & copyin (paprs, pplay, t , q) &
207  !$acc & copyout (d_t, d_q)
208
209  ! Initialisation:
210
211  ! ym
212  limbas = 1
213  limhau = klev
214
215  !$acc kernels default(none) async
216  DO k = 1, klev
217    DO i = 1, klon
218      d_t(i, k) = 0.0
219      d_q(i, k) = 0.0
220    END DO
221  END DO
222  !$acc end kernels
223
224  ! ------------------------------------- detection des profils a modifier
225  !$acc kernels default(none) async
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  !$acc end kernels
251  ! ------------------------------------- correction des profils instables
252  !$acc kernels default(none) async
253  DO i = 1, klon
254    IF (modif(i)) THEN
255      k2 = limbas
2568000  CONTINUE
257      k2 = k2 + 1
258      IF (k2>limhau) GO TO 8001
259      IF (zh(i,k2)<zh(i,k2-1)) THEN
260        k1 = k2 - 1
261        k = k1
262        sm = zpkdp(i, k2)
263        hm = zh(i, k2)
264        qm = zq(i, k2)
2658020    CONTINUE
266        sm = sm + zpkdp(i, k)
267        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
268        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
269        down = .FALSE.
270        IF (k1/=limbas) THEN
271          IF (hm<zh(i,k1-1)) down = .TRUE.
272        END IF
273        IF (down) THEN
274          k1 = k1 - 1
275          k = k1
276        ELSE
277          IF ((k2==limhau)) GO TO 8021
278          IF ((zh(i,k2+1)>=hm)) GO TO 8021
279          k2 = k2 + 1
280          k = k2
281        END IF
282        GO TO 8020
2838021    CONTINUE
284        ! ------------ nouveau profil : constant (valeur moyenne)
285        DO k = k1, k2
286          zh(i, k) = hm
287          zq(i, k) = qm
288        END DO
289        k2 = k2 + 1
290      END IF
291      GO TO 8000
2928001  CONTINUE
293    END IF
294  END DO
295  !$acc end kernels
296
297  !$acc kernels default(none) async
298  DO k = limbas, limhau
299    DO i = 1, klon
300      d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k)
301      d_q(i, k) = zq(i, k) - q(i, k)
302    END DO
303  END DO
304  !$acc end kernels
305
306  IF (limbas>1) THEN
307  !$acc kernels default(none) async
308    DO k = 1, limbas - 1
309      DO i = 1, klon
310        d_t(i, k) = 0.0
311        d_q(i, k) = 0.0
312      END DO
313    END DO
314  !$acc end kernels
315  END IF
316
317  IF (limhau<klev) THEN
318  !$acc kernels default(none) async
319    DO k = limhau + 1, klev
320      DO i = 1, klon
321        d_t(i, k) = 0.0
322        d_q(i, k) = 0.0
323      END DO
324    END DO
325  !$acc end kernels
326  END IF
327
328  IF (.NOT. mixq) THEN
329  !$acc kernels default(none) async
330    DO k = 1, klev
331      DO i = 1, klon
332        d_q(i, k) = 0.0
333      END DO
334    END DO
335  !$acc end kernels
336  END IF
337
338  !$acc end data
339
340  RETURN
341
342
343END SUBROUTINE ajsec_convv2
344SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
345  USE dimphy
346  IMPLICIT NONE
347  ! ======================================================================
348  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
349  ! Objet: ajustement sec (adaptation du GCM du LMD)
350  ! ======================================================================
351  ! Arguments:
352  ! t-------input-R- Temperature
353
354  ! d_t-----output-R-Incrementation de la temperature
355  ! ======================================================================
356  include "YOMCST.h"
357  REAL paprs(klon, klev+1), pplay(klon, klev)
358  REAL t(klon, klev)
359  REAL d_t(klon, klev)
360
361  REAL local_h(klon, klev)
362  REAL hm, sm
363  LOGICAL modif(klon), down
364  INTEGER i, l, l1, l2
365
366  !$acc data create (local_h, modif) &
367  !$acc & copyin (paprs, pplay, t) &
368  !$acc & copyout (d_t)
369
370  ! ------------------------------------- detection des profils a modifier
371  !$acc kernels default(none) async
372  DO i = 1, klon
373    modif(i) = .FALSE.
374  END DO
375
376  DO l = 1, klev
377    DO i = 1, klon
378      local_h(i, l) = rcpd*t(i, l)/(pplay(i,l)**rkappa)
379    END DO
380  END DO
381
382  DO l = 2, klev
383    DO i = 1, klon
384      IF (local_h(i,l)<local_h(i,l-1)) THEN
385        modif(i) = .TRUE.
386      ELSE
387        modif(i) = modif(i)
388      END IF
389    END DO
390  END DO
391  !$acc end kernels
392  ! ------------------------------------- correction des profils instables
393  !$acc kernels default(none) async
394  DO i = 1, klon
395    IF (modif(i)) THEN
396      l2 = 1
3978000  CONTINUE
398      l2 = l2 + 1
399      IF (l2>klev) GO TO 8001
400      IF (local_h(i,l2)<local_h(i,l2-1)) THEN
401        l1 = l2 - 1
402        l = l1
403        sm = pplay(i, l2)**rkappa*(paprs(i,l2)-paprs(i,l2+1))
404        hm = local_h(i, l2)
4058020    CONTINUE
406        sm = sm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))
407        hm = hm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))*(local_h(i,l) &
408          -hm)/sm
409        down = .FALSE.
410        IF (l1/=1) THEN
411          IF (hm<local_h(i,l1-1)) THEN
412            down = .TRUE.
413          END IF
414        END IF
415        IF (down) THEN
416          l1 = l1 - 1
417          l = l1
418        ELSE
419          IF ((l2==klev)) GO TO 8021
420          IF ((local_h(i,l2+1)>=hm)) GO TO 8021
421          l2 = l2 + 1
422          l = l2
423        END IF
424        GO TO 8020
4258021    CONTINUE
426        ! ------------ nouveau profil : constant (valeur moyenne)
427        DO l = l1, l2
428          local_h(i, l) = hm
429        END DO
430        l2 = l2 + 1
431      END IF
432      GO TO 8000
4338001  CONTINUE
434    END IF
435  END DO
436  !$acc end kernels
437
438  !$acc kernels default(none) async
439  DO l = 1, klev
440    DO i = 1, klon
441      d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l)
442    END DO
443  END DO
444  !$acc end kernels
445  !$acc end data
446
447  RETURN
448
449
450END SUBROUTINE ajsec_old
Note: See TracBrowser for help on using the repository browser.