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

Last change on this file since 4132 was 4132, checked in by Laurent Fairhead, 2 years ago

Modifications to code to start using openacc directives
LF
  • 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.4 KB
Line 
1
2! $Id: ajsec.F90 4132 2022-04-20 16:35:42Z fairhead $
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 paprs(klon, klev+1), pplay(klon, klev)
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.)
25  PARAMETER (mixq=.FALSE.)
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  !$acc data create (zh, zho, zq,zpk,zpkdp,modif) &
37  !$acc &    copyin (paprs, pplay, t , q, limbas) &
38  !$acc &    copyout (d_t, d_q)                   &
39  !$acc &
40 
41  ! Initialisation:
42
43  ! ym
44  limhau = klev
45
46  !$acc kernels default(none) async
47  DO k = 1, klev
48    DO i = 1, klon
49      d_t(i, k) = 0.0
50      d_q(i, k) = 0.0
51    END DO
52  END DO
53  ! ------------------------------------- detection des profils a modifier
54  DO k = 1, limhau
55    DO i = 1, klon
56      zpk(i, k) = pplay(i, k)**rkappa
57      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
58      zho(i, k) = zh(i, k)
59      zq(i, k) = q(i, k)
60    END DO
61  END DO
62
63  DO k = 1, limhau
64    DO i = 1, klon
65      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
66    END DO
67  END DO
68
69  DO i = 1, klon
70    modif(i) = .FALSE.
71  END DO
72  DO k = 2, limhau
73    DO i = 1, klon
74      IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN
75        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
76      END IF
77    END DO
78  END DO
79  !$acc end kernels
80  ! ------------------------------------- correction des profils instables
81  !$acc kernels default(none) async
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  !$acc end kernels
125
126  !$acc kernels default(none) async
127  DO k = 1, limhau
128    DO i = 1, klon
129      d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd
130      d_q(i, k) = zq(i, k) - q(i, k)
131    END DO
132  END DO
133  !$acc end kernels
134
135  ! FH : les d_q et d_t sont maintenant calcules de facon a valoir
136  ! effectivement 0. si on ne fait rien.
137
138  ! IF (limbas.GT.1) THEN
139  ! DO k = 1, limbas-1
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 (limhau.LT.klev) THEN
148  ! DO k = limhau+1, klev
149  ! DO i = 1, klon
150  ! d_t(i,k) = 0.0
151  ! d_q(i,k) = 0.0
152  ! ENDDO
153  ! ENDDO
154  ! ENDIF
155
156  IF (.NOT. mixq) THEN
157    !$acc kernels default(none) async
158    DO k = 1, klev
159      DO i = 1, klon
160        d_q(i, k) = 0.0
161      END DO
162    END DO
163    !$acc end kernels
164  END IF
165  !$acc end data
166
167  RETURN
168
169END SUBROUTINE ajsec
170
171SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q)
172  USE dimphy
173  IMPLICIT NONE
174  ! ======================================================================
175  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
176  ! Objet: ajustement sec (adaptation du GCM du LMD)
177  ! ======================================================================
178  ! Arguments:
179  ! t-------input-R- Temperature
180
181  ! d_t-----output-R-Incrementation de la temperature
182  ! ======================================================================
183  include "YOMCST.h"
184  REAL paprs(klon, klev+1), pplay(klon, klev)
185  REAL t(klon, klev), q(klon, klev)
186  REAL d_t(klon, klev), d_q(klon, klev)
187
188  INTEGER limbas, limhau ! les couches a ajuster
189  ! cc      PARAMETER (limbas=klev-3, limhau=klev)
190  ! ym      PARAMETER (limbas=1, limhau=klev)
191
192  LOGICAL mixq
193  ! cc      PARAMETER (mixq=.TRUE.)
194  PARAMETER (mixq=.FALSE.)
195
196  REAL zh(klon, klev)
197  REAL zq(klon, klev)
198  REAL zpk(klon, klev)
199  REAL zpkdp(klon, klev)
200  REAL hm, sm, qm
201  LOGICAL modif(klon), down
202  INTEGER i, k, k1, k2
203
204  !$acc data create (zh, zq, zpk, zpkdp, modif) &
205  !$acc & copyin (paprs, pplay, t , q) &
206  !$acc & copyout (d_t, d_q)
207
208  ! Initialisation:
209
210  ! ym
211  limbas = 1
212  limhau = klev
213
214  !$acc kernels default(none) async
215  DO k = 1, klev
216    DO i = 1, klon
217      d_t(i, k) = 0.0
218      d_q(i, k) = 0.0
219    END DO
220  END DO
221  !$acc end kernels
222
223  ! ------------------------------------- detection des profils a modifier
224  !$acc kernels default(none) async
225  DO k = limbas, limhau
226    DO i = 1, klon
227      zpk(i, k) = pplay(i, k)**rkappa
228      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
229      zq(i, k) = q(i, k)
230    END DO
231  END DO
232
233  DO k = limbas, limhau
234    DO i = 1, klon
235      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
236    END DO
237  END DO
238
239  DO i = 1, klon
240    modif(i) = .FALSE.
241  END DO
242  DO k = limbas + 1, limhau
243    DO i = 1, klon
244      IF (.NOT. modif(i)) THEN
245        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
246      END IF
247    END DO
248  END DO
249  !$acc end kernels
250  ! ------------------------------------- correction des profils instables
251  !$acc kernels default(none) async
252  DO i = 1, klon
253    IF (modif(i)) THEN
254      k2 = limbas
2558000  CONTINUE
256      k2 = k2 + 1
257      IF (k2>limhau) GO TO 8001
258      IF (zh(i,k2)<zh(i,k2-1)) THEN
259        k1 = k2 - 1
260        k = k1
261        sm = zpkdp(i, k2)
262        hm = zh(i, k2)
263        qm = zq(i, k2)
2648020    CONTINUE
265        sm = sm + zpkdp(i, k)
266        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
267        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
268        down = .FALSE.
269        IF (k1/=limbas) THEN
270          IF (hm<zh(i,k1-1)) down = .TRUE.
271        END IF
272        IF (down) THEN
273          k1 = k1 - 1
274          k = k1
275        ELSE
276          IF ((k2==limhau)) GO TO 8021
277          IF ((zh(i,k2+1)>=hm)) GO TO 8021
278          k2 = k2 + 1
279          k = k2
280        END IF
281        GO TO 8020
2828021    CONTINUE
283        ! ------------ nouveau profil : constant (valeur moyenne)
284        DO k = k1, k2
285          zh(i, k) = hm
286          zq(i, k) = qm
287        END DO
288        k2 = k2 + 1
289      END IF
290      GO TO 8000
2918001  CONTINUE
292    END IF
293  END DO
294  !$acc end kernels
295
296  !$acc kernels default(none) async
297  DO k = limbas, limhau
298    DO i = 1, klon
299      d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k)
300      d_q(i, k) = zq(i, k) - q(i, k)
301    END DO
302  END DO
303  !$acc end kernels
304
305  IF (limbas>1) THEN
306  !$acc kernels default(none) async
307    DO k = 1, limbas - 1
308      DO i = 1, klon
309        d_t(i, k) = 0.0
310        d_q(i, k) = 0.0
311      END DO
312    END DO
313  !$acc end kernels
314  END IF
315
316  IF (limhau<klev) THEN
317  !$acc kernels default(none) async
318    DO k = limhau + 1, klev
319      DO i = 1, klon
320        d_t(i, k) = 0.0
321        d_q(i, k) = 0.0
322      END DO
323    END DO
324  !$acc end kernels
325  END IF
326
327  IF (.NOT. mixq) THEN
328  !$acc kernels default(none) async
329    DO k = 1, klev
330      DO i = 1, klon
331        d_q(i, k) = 0.0
332      END DO
333    END DO
334  !$acc end kernels
335  END IF
336
337  !$acc end data
338
339  RETURN
340
341
342END SUBROUTINE ajsec_convv2
343SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
344  USE dimphy
345  IMPLICIT NONE
346  ! ======================================================================
347  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
348  ! Objet: ajustement sec (adaptation du GCM du LMD)
349  ! ======================================================================
350  ! Arguments:
351  ! t-------input-R- Temperature
352
353  ! d_t-----output-R-Incrementation de la temperature
354  ! ======================================================================
355  include "YOMCST.h"
356  REAL paprs(klon, klev+1), pplay(klon, klev)
357  REAL t(klon, klev)
358  REAL d_t(klon, klev)
359
360  REAL local_h(klon, klev)
361  REAL hm, sm
362  LOGICAL modif(klon), down
363  INTEGER i, l, l1, l2
364
365  !$acc data create (local_h, modif) &
366  !$acc & copyin (paprs, pplay, t) &
367  !$acc & copyout (d_t)
368
369  ! ------------------------------------- detection des profils a modifier
370  !$acc kernels default(none) async
371  DO i = 1, klon
372    modif(i) = .FALSE.
373  END DO
374
375  DO l = 1, klev
376    DO i = 1, klon
377      local_h(i, l) = rcpd*t(i, l)/(pplay(i,l)**rkappa)
378    END DO
379  END DO
380
381  DO l = 2, klev
382    DO i = 1, klon
383      IF (local_h(i,l)<local_h(i,l-1)) THEN
384        modif(i) = .TRUE.
385      ELSE
386        modif(i) = modif(i)
387      END IF
388    END DO
389  END DO
390  !$acc end kernels
391  ! ------------------------------------- correction des profils instables
392  !$acc kernels default(none) async
393  DO i = 1, klon
394    IF (modif(i)) THEN
395      l2 = 1
3968000  CONTINUE
397      l2 = l2 + 1
398      IF (l2>klev) GO TO 8001
399      IF (local_h(i,l2)<local_h(i,l2-1)) THEN
400        l1 = l2 - 1
401        l = l1
402        sm = pplay(i, l2)**rkappa*(paprs(i,l2)-paprs(i,l2+1))
403        hm = local_h(i, l2)
4048020    CONTINUE
405        sm = sm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))
406        hm = hm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))*(local_h(i,l) &
407          -hm)/sm
408        down = .FALSE.
409        IF (l1/=1) THEN
410          IF (hm<local_h(i,l1-1)) THEN
411            down = .TRUE.
412          END IF
413        END IF
414        IF (down) THEN
415          l1 = l1 - 1
416          l = l1
417        ELSE
418          IF ((l2==klev)) GO TO 8021
419          IF ((local_h(i,l2+1)>=hm)) GO TO 8021
420          l2 = l2 + 1
421          l = l2
422        END IF
423        GO TO 8020
4248021    CONTINUE
425        ! ------------ nouveau profil : constant (valeur moyenne)
426        DO l = l1, l2
427          local_h(i, l) = hm
428        END DO
429        l2 = l2 + 1
430      END IF
431      GO TO 8000
4328001  CONTINUE
433    END IF
434  END DO
435  !$acc end kernels
436
437  !$acc kernels default(none) async
438  DO l = 1, klev
439    DO i = 1, klon
440      d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l)
441    END DO
442  END DO
443  !$acc end kernels
444  !$acc end data
445
446  RETURN
447
448
449END SUBROUTINE ajsec_old
Note: See TracBrowser for help on using the repository browser.