source: LMDZ6/branches/Amaury_dev/libf/dyn3dmem/call_dissip_mod.f90 @ 5105

Last change on this file since 5105 was 5103, checked in by abarral, 4 months ago

Handle CPP_INLANDSIS in lmdz_cppkeys_wrapper.F90
Remove obsolete key wrgrads_thermcell, _ADV_HALO, _ADV_HALLO, isminmax
Remove redundant uses of CPPKEY_INCA (thanks acozic)
Remove obsolete misc/write_field.F90
Remove unused ioipsl_* wrappers
Remove calls to WriteField_u with wrong signature
Convert .F -> .[fF]90
(lint) uppercase fortran operators
[note: 1d and iso still broken - working on it]
  • 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
File size: 9.1 KB
Line 
1MODULE call_dissip_mod
2
3  REAL, POINTER, SAVE :: ucov(:, :)
4  REAL, POINTER, SAVE :: vcov(:, :)
5  REAL, POINTER, SAVE :: teta(:, :)
6  REAL, POINTER, SAVE :: p(:, :)
7  REAL, POINTER, SAVE :: pk(:, :)
8
9  REAL, POINTER, SAVE :: ucont(:, :)
10  REAL, POINTER, SAVE :: vcont(:, :)
11  REAL, POINTER, SAVE :: ecin(:, :)
12  REAL, POINTER, SAVE :: ecin0(:, :)
13  REAL, POINTER, SAVE :: dudis(:, :)
14  REAL, POINTER, SAVE :: dvdis(:, :)
15  REAL, POINTER, SAVE :: dtetadis(:, :)
16  REAL, POINTER, SAVE :: dtetaecdt(:, :)
17
18
19CONTAINS
20
21  SUBROUTINE call_dissip_allocate
22    USE bands
23    USE allocate_field_mod
24    USE parallel_lmdz
25    USE dimensions_mod
26    USE dissip_mod, ONLY: dissip_allocate
27    IMPLICIT NONE
28    TYPE(distrib), POINTER :: d
29    d => distrib_dissip
30
31    CALL allocate_u(ucov, llm, d)
32    ucov(:, :) = 0
33    CALL allocate_v(vcov, llm, d)
34    vcov(:, :) = 0
35    CALL allocate_u(teta, llm, d)
36    CALL allocate_u(p, llmp1, d)
37    CALL allocate_u(pk, llm, d)
38    CALL allocate_u(ucont, llm, d)
39    CALL allocate_v(vcont, llm, d)
40    CALL allocate_u(ecin, llm, d)
41    CALL allocate_u(ecin0, llm, d)
42    CALL allocate_u(dudis, llm, d)
43    CALL allocate_v(dvdis, llm, d)
44    CALL allocate_u(dtetadis, llm, d)
45    CALL allocate_u(dtetaecdt, llm, d)
46
47    CALL dissip_allocate
48
49  END SUBROUTINE call_dissip_allocate
50
51  SUBROUTINE call_dissip_switch_dissip(dist)
52    USE allocate_field_mod
53    USE bands
54    USE parallel_lmdz
55    USE dissip_mod, ONLY: dissip_switch_dissip
56    IMPLICIT NONE
57    TYPE(distrib), INTENT(IN) :: dist
58
59    CALL switch_u(ucov, distrib_dissip, dist)
60    CALL switch_v(vcov, distrib_dissip, dist)
61    CALL switch_u(teta, distrib_dissip, dist)
62    CALL switch_u(p, distrib_dissip, dist)
63    CALL switch_u(pk, distrib_dissip, dist)
64    CALL switch_u(ucont, distrib_dissip, dist)
65    CALL switch_v(vcont, distrib_dissip, dist)
66    CALL switch_u(ecin, distrib_dissip, dist)
67    CALL switch_u(ecin0, distrib_dissip, dist)
68    CALL switch_u(dudis, distrib_dissip, dist)
69    CALL switch_v(dvdis, distrib_dissip, dist)
70    CALL switch_u(dtetadis, distrib_dissip, dist)
71    CALL switch_u(dtetaecdt, distrib_dissip, dist)
72
73    CALL dissip_switch_dissip(dist)
74
75  END SUBROUTINE call_dissip_switch_dissip
76
77
78  SUBROUTINE call_dissip(ucov_dyn, vcov_dyn, teta_dyn, p_dyn, pk_dyn, ps_dyn)
79    USE dimensions_mod
80    USE parallel_lmdz
81    USE times
82    USE mod_hallo
83    USE Bands
84    USE vampir
85    USE write_field_loc
86    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
87
88    IMPLICIT NONE
89    INCLUDE 'comgeom.h'
90    REAL, INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u, llm) ! covariant zonal wind
91    REAL, INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v, llm) ! covariant meridional wind
92    REAL, INTENT(INOUT) :: teta_dyn(ijb_u:ije_u, llm) ! covariant meridional wind
93    REAL, INTENT(INOUT) :: p_dyn(ijb_u:ije_u, llmp1) ! pressure at interlayer
94    REAL, INTENT(INOUT) :: pk_dyn(ijb_u:ije_u, llm) ! Exner at midlayer
95    REAL, INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure
96    REAL :: tppn(iim), tpps(iim)
97    REAL :: tpn, tps
98
99    REAL  SSUM
100    LOGICAL, PARAMETER :: dissip_conservative = .TRUE.
101    TYPE(Request), SAVE :: Request_dissip
102    !$OMP THREADPRIVATE(Request_dissip )
103    INTEGER :: ij, l, ijb, ije
104
105
106    !$OMP MASTER
107    CALL suspend_timer(timer_caldyn)
108
109    !       PRINT*,'Entree dans la dissipation : Iteration No ',true_itau
110    !   calcul de l'energie cinetique avant dissipation
111    !       print *,'Passage dans la dissipation'
112
113    CALL VTb(VThallo)
114    !$OMP END MASTER
115
116    !$OMP BARRIER
117
118    CALL Register_SwapField_u(ucov_dyn, ucov, distrib_dissip, Request_dissip, up = 1, down = 1)
119    CALL Register_SwapField_v(vcov_dyn, vcov, distrib_dissip, Request_dissip, up = 1, down = 1)
120    CALL Register_SwapField_u(teta_dyn, teta, distrib_dissip, Request_dissip)
121    CALL Register_SwapField_u(p_dyn, p, distrib_dissip, Request_dissip)
122    CALL Register_SwapField_u(pk_dyn, pk, distrib_dissip, Request_dissip)
123
124    CALL SendRequest(Request_dissip)
125    !$OMP BARRIER
126    CALL WaitRequest(Request_dissip)
127
128    !$OMP BARRIER
129    !$OMP MASTER
130    CALL set_distrib(distrib_dissip)
131    CALL VTe(VThallo)
132    CALL VTb(VTdissipation)
133    CALL start_timer(timer_dissip)
134    !$OMP END MASTER
135    !$OMP BARRIER
136
137    CALL covcont_loc(llm, ucov, vcov, ucont, vcont)
138    CALL enercin_loc(vcov, ucov, vcont, ucont, ecin0)
139
140    !   dissipation
141
142    !        CALL FTRACE_REGION_BEGIN("dissip")
143    CALL dissip_loc(vcov, ucov, teta, p, dvdis, dudis, dtetadis)
144
145    IF (CPPKEY_DEBUGIO) THEN
146      CALL WriteField_u('dudis', dudis)
147      CALL WriteField_v('dvdis', dvdis)
148      CALL WriteField_u('dtetadis', dtetadis)
149    END IF
150
151    !      CALL FTRACE_REGION_END("dissip")
152
153    ijb = ij_begin
154    ije = ij_end
155    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
156    DO l = 1, llm
157      ucov(ijb:ije, l) = ucov(ijb:ije, l) + dudis(ijb:ije, l)
158    ENDDO
159    !$OMP END DO NOWAIT
160
161    IF (pole_sud) ije = ije - iip1
162
163    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
164    DO l = 1, llm
165      vcov(ijb:ije, l) = vcov(ijb:ije, l) + dvdis(ijb:ije, l)
166    ENDDO
167    !$OMP END DO NOWAIT
168
169    !       teta=teta+dtetadis
170
171
172    !------------------------------------------------------------------------
173    IF (dissip_conservative) THEN
174      !       On rajoute la tendance due a la transform. Ec -> E therm. cree
175      !       lors de la dissipation
176      !$OMP BARRIER
177      !$OMP MASTER
178      CALL suspend_timer(timer_dissip)
179      CALL VTb(VThallo)
180      !$OMP END MASTER
181      CALL Register_Hallo_u(ucov, llm, 1, 1, 1, 1, Request_Dissip)
182      CALL Register_Hallo_v(vcov, llm, 1, 1, 1, 1, Request_Dissip)
183      CALL SendRequest(Request_Dissip)
184      !$OMP BARRIER
185      CALL WaitRequest(Request_Dissip)
186      !$OMP MASTER
187      CALL VTe(VThallo)
188      CALL resume_timer(timer_dissip)
189      !$OMP END MASTER
190      !$OMP BARRIER
191      CALL covcont_loc(llm, ucov, vcov, ucont, vcont)
192      CALL enercin_loc(vcov, ucov, vcont, ucont, ecin)
193
194      ijb = ij_begin
195      ije = ij_end
196      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
197      DO l = 1, llm
198        DO ij = ijb, ije
199          dtetaecdt(ij, l) = (ecin0(ij, l) - ecin(ij, l)) / pk(ij, l)
200          dtetadis(ij, l) = dtetadis(ij, l) + dtetaecdt(ij, l)
201        ENDDO
202      ENDDO
203      !$OMP END DO NOWAIT
204
205    ENDIF
206
207    ijb = ij_begin
208    ije = ij_end
209
210    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
211    DO l = 1, llm
212      DO ij = ijb, ije
213        teta(ij, l) = teta(ij, l) + dtetadis(ij, l)
214      ENDDO
215    ENDDO
216    !$OMP END DO NOWAIT
217
218    !------------------------------------------------------------------------
219
220
221    !    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
222    !   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
223
224    ijb = ij_begin
225    ije = ij_end
226
227    IF (pole_nord) THEN
228
229      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
230      DO l = 1, llm
231        DO ij = 1, iim
232          tppn(ij) = aire(ij) * teta(ij, l)
233        ENDDO
234        tpn = SSUM(iim, tppn, 1) / apoln
235
236        DO ij = 1, iip1
237          teta(ij, l) = tpn
238        ENDDO
239      ENDDO
240      !$OMP END DO NOWAIT
241
242      if (1 == 0) then
243        !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
244        !!!                     2) should probably not be here anyway
245        !!! but are kept for those who would want to revert to previous behaviour
246        !$OMP MASTER
247        DO ij = 1, iim
248          tppn(ij) = aire(ij) * ps_dyn (ij)
249        ENDDO
250        tpn = SSUM(iim, tppn, 1) / apoln
251
252        DO ij = 1, iip1
253          ps_dyn(ij) = tpn
254        ENDDO
255        !$OMP END MASTER
256
257      ENDIF ! of if (1 == 0)
258    endif ! of of (pole_nord)
259
260    IF (pole_sud) THEN
261
262      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
263      DO l = 1, llm
264        DO ij = 1, iim
265          tpps(ij) = aire(ij + ip1jm) * teta(ij + ip1jm, l)
266        ENDDO
267
268        tps = SSUM(iim, tpps, 1) / apols
269
270        DO ij = 1, iip1
271          teta(ij + ip1jm, l) = tps
272        ENDDO
273      ENDDO
274      !$OMP END DO NOWAIT
275
276      if (1 == 0) then
277        !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
278        !!!                     2) should probably not be here anyway
279        !!! but are kept for those who would want to revert to previous behaviour
280        !$OMP MASTER
281        DO ij = 1, iim
282          tpps(ij) = aire(ij + ip1jm) * ps_dyn (ij + ip1jm)
283        ENDDO
284        tps = SSUM(iim, tpps, 1) / apols
285
286        DO ij = 1, iip1
287          ps_dyn(ij + ip1jm) = tps
288        ENDDO
289        !$OMP END MASTER
290      ENDIF ! of if (1 == 0)
291    endif ! of if (pole_sud)
292
293
294    !$OMP BARRIER
295    !$OMP MASTER
296    CALL VTe(VTdissipation)
297    CALL stop_timer(timer_dissip)
298    CALL VTb(VThallo)
299    !$OMP END MASTER
300
301    CALL Register_SwapField_u(ucov, ucov_dyn, distrib_caldyn, Request_dissip)
302    CALL Register_SwapField_v(vcov, vcov_dyn, distrib_caldyn, Request_dissip)
303    CALL Register_SwapField_u(teta, teta_dyn, distrib_caldyn, Request_dissip)
304    CALL Register_SwapField_u(p, p_dyn, distrib_caldyn, Request_dissip)
305    CALL Register_SwapField_u(pk, pk_dyn, distrib_caldyn, Request_dissip)
306
307    CALL SendRequest(Request_dissip)
308
309    !$OMP BARRIER
310    CALL WaitRequest(Request_dissip)
311    !$OMP BARRIER
312    !$OMP MASTER
313    CALL set_distrib(distrib_caldyn)
314    CALL VTe(VThallo)
315    CALL resume_timer(timer_caldyn)
316    !        print *,'fin dissipation'
317    !$OMP END MASTER
318    !$OMP BARRIER
319
320  END SUBROUTINE call_dissip
321
322END MODULE call_dissip_mod
Note: See TracBrowser for help on using the repository browser.