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

Last change on this file since 5133 was 5123, checked in by abarral, 5 months ago

Correct various minor mistakes from previous commits
  • 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 lmdz_vampir
85    USE write_field_loc
86    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
87    USE lmdz_ssum_scopy, ONLY: ssum
88
89
90    IMPLICIT NONE
91    INCLUDE 'comgeom.h'
92    REAL, INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u, llm) ! covariant zonal wind
93    REAL, INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v, llm) ! covariant meridional wind
94    REAL, INTENT(INOUT) :: teta_dyn(ijb_u:ije_u, llm) ! covariant meridional wind
95    REAL, INTENT(INOUT) :: p_dyn(ijb_u:ije_u, llmp1) ! pressure at interlayer
96    REAL, INTENT(INOUT) :: pk_dyn(ijb_u:ije_u, llm) ! Exner at midlayer
97    REAL, INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure
98    REAL :: tppn(iim), tpps(iim)
99    REAL :: tpn, tps
100
101    LOGICAL, PARAMETER :: dissip_conservative = .TRUE.
102    TYPE(Request), SAVE :: Request_dissip
103    !$OMP THREADPRIVATE(Request_dissip )
104    INTEGER :: ij, l, ijb, ije
105
106
107    !$OMP MASTER
108    CALL suspend_timer(timer_caldyn)
109
110    !       PRINT*,'Entree dans la dissipation : Iteration No ',true_itau
111    !   calcul de l'energie cinetique avant dissipation
112    !       print *,'Passage dans la dissipation'
113
114    CALL VTb(VThallo)
115    !$OMP END MASTER
116
117    !$OMP BARRIER
118
119    CALL Register_SwapField_u(ucov_dyn, ucov, distrib_dissip, Request_dissip, up = 1, down = 1)
120    CALL Register_SwapField_v(vcov_dyn, vcov, distrib_dissip, Request_dissip, up = 1, down = 1)
121    CALL Register_SwapField_u(teta_dyn, teta, distrib_dissip, Request_dissip)
122    CALL Register_SwapField_u(p_dyn, p, distrib_dissip, Request_dissip)
123    CALL Register_SwapField_u(pk_dyn, pk, distrib_dissip, Request_dissip)
124
125    CALL SendRequest(Request_dissip)
126    !$OMP BARRIER
127    CALL WaitRequest(Request_dissip)
128
129    !$OMP BARRIER
130    !$OMP MASTER
131    CALL set_distrib(distrib_dissip)
132    CALL VTe(VThallo)
133    CALL VTb(VTdissipation)
134    CALL start_timer(timer_dissip)
135    !$OMP END MASTER
136    !$OMP BARRIER
137
138    CALL covcont_loc(llm, ucov, vcov, ucont, vcont)
139    CALL enercin_loc(vcov, ucov, vcont, ucont, ecin0)
140
141    !   dissipation
142
143    !        CALL FTRACE_REGION_BEGIN("dissip")
144    CALL dissip_loc(vcov, ucov, teta, p, dvdis, dudis, dtetadis)
145
146    IF (CPPKEY_DEBUGIO) THEN
147      CALL WriteField_u('dudis', dudis)
148      CALL WriteField_v('dvdis', dvdis)
149      CALL WriteField_u('dtetadis', dtetadis)
150    END IF
151
152    !      CALL FTRACE_REGION_END("dissip")
153
154    ijb = ij_begin
155    ije = ij_end
156    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
157    DO l = 1, llm
158      ucov(ijb:ije, l) = ucov(ijb:ije, l) + dudis(ijb:ije, l)
159    ENDDO
160    !$OMP END DO NOWAIT
161
162    IF (pole_sud) ije = ije - iip1
163
164    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
165    DO l = 1, llm
166      vcov(ijb:ije, l) = vcov(ijb:ije, l) + dvdis(ijb:ije, l)
167    ENDDO
168    !$OMP END DO NOWAIT
169
170    !       teta=teta+dtetadis
171
172
173    !------------------------------------------------------------------------
174    IF (dissip_conservative) THEN
175      !       On rajoute la tendance due a la transform. Ec -> E therm. cree
176      !       lors de la dissipation
177      !$OMP BARRIER
178      !$OMP MASTER
179      CALL suspend_timer(timer_dissip)
180      CALL VTb(VThallo)
181      !$OMP END MASTER
182      CALL Register_Hallo_u(ucov, llm, 1, 1, 1, 1, Request_Dissip)
183      CALL Register_Hallo_v(vcov, llm, 1, 1, 1, 1, Request_Dissip)
184      CALL SendRequest(Request_Dissip)
185      !$OMP BARRIER
186      CALL WaitRequest(Request_Dissip)
187      !$OMP MASTER
188      CALL VTe(VThallo)
189      CALL resume_timer(timer_dissip)
190      !$OMP END MASTER
191      !$OMP BARRIER
192      CALL covcont_loc(llm, ucov, vcov, ucont, vcont)
193      CALL enercin_loc(vcov, ucov, vcont, ucont, ecin)
194
195      ijb = ij_begin
196      ije = ij_end
197      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
198      DO l = 1, llm
199        DO ij = ijb, ije
200          dtetaecdt(ij, l) = (ecin0(ij, l) - ecin(ij, l)) / pk(ij, l)
201          dtetadis(ij, l) = dtetadis(ij, l) + dtetaecdt(ij, l)
202        ENDDO
203      ENDDO
204      !$OMP END DO NOWAIT
205
206    ENDIF
207
208    ijb = ij_begin
209    ije = ij_end
210
211    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
212    DO l = 1, llm
213      DO ij = ijb, ije
214        teta(ij, l) = teta(ij, l) + dtetadis(ij, l)
215      ENDDO
216    ENDDO
217    !$OMP END DO NOWAIT
218
219    !------------------------------------------------------------------------
220
221
222    !    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
223    !   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
224
225    ijb = ij_begin
226    ije = ij_end
227
228    IF (pole_nord) THEN
229
230      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
231      DO l = 1, llm
232        DO ij = 1, iim
233          tppn(ij) = aire(ij) * teta(ij, l)
234        ENDDO
235        tpn = SSUM(iim, tppn, 1) / apoln
236
237        DO ij = 1, iip1
238          teta(ij, l) = tpn
239        ENDDO
240      ENDDO
241      !$OMP END DO NOWAIT
242
243      IF (1 == 0) THEN
244        !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
245        !!!                     2) should probably not be here anyway
246        !!! but are kept for those who would want to revert to previous behaviour
247        !$OMP MASTER
248        DO ij = 1, iim
249          tppn(ij) = aire(ij) * ps_dyn (ij)
250        ENDDO
251        tpn = SSUM(iim, tppn, 1) / apoln
252
253        DO ij = 1, iip1
254          ps_dyn(ij) = tpn
255        ENDDO
256        !$OMP END MASTER
257
258      ENDIF ! of if (1 == 0)
259    endif ! of of (pole_nord)
260
261    IF (pole_sud) THEN
262
263      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
264      DO l = 1, llm
265        DO ij = 1, iim
266          tpps(ij) = aire(ij + ip1jm) * teta(ij + ip1jm, l)
267        ENDDO
268
269        tps = SSUM(iim, tpps, 1) / apols
270
271        DO ij = 1, iip1
272          teta(ij + ip1jm, l) = tps
273        ENDDO
274      ENDDO
275      !$OMP END DO NOWAIT
276
277      IF (1 == 0) THEN
278        !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
279        !!!                     2) should probably not be here anyway
280        !!! but are kept for those who would want to revert to previous behaviour
281        !$OMP MASTER
282        DO ij = 1, iim
283          tpps(ij) = aire(ij + ip1jm) * ps_dyn (ij + ip1jm)
284        ENDDO
285        tps = SSUM(iim, tpps, 1) / apols
286
287        DO ij = 1, iip1
288          ps_dyn(ij + ip1jm) = tps
289        ENDDO
290        !$OMP END MASTER
291      ENDIF ! of if (1 == 0)
292    endif ! of if (pole_sud)
293
294
295    !$OMP BARRIER
296    !$OMP MASTER
297    CALL VTe(VTdissipation)
298    CALL stop_timer(timer_dissip)
299    CALL VTb(VThallo)
300    !$OMP END MASTER
301
302    CALL Register_SwapField_u(ucov, ucov_dyn, distrib_caldyn, Request_dissip)
303    CALL Register_SwapField_v(vcov, vcov_dyn, distrib_caldyn, Request_dissip)
304    CALL Register_SwapField_u(teta, teta_dyn, distrib_caldyn, Request_dissip)
305    CALL Register_SwapField_u(p, p_dyn, distrib_caldyn, Request_dissip)
306    CALL Register_SwapField_u(pk, pk_dyn, distrib_caldyn, Request_dissip)
307
308    CALL SendRequest(Request_dissip)
309
310    !$OMP BARRIER
311    CALL WaitRequest(Request_dissip)
312    !$OMP BARRIER
313    !$OMP MASTER
314    CALL set_distrib(distrib_caldyn)
315    CALL VTe(VThallo)
316    CALL resume_timer(timer_caldyn)
317    !        print *,'fin dissipation'
318    !$OMP END MASTER
319    !$OMP BARRIER
320
321  END SUBROUTINE call_dissip
322
323END MODULE call_dissip_mod
Note: See TracBrowser for help on using the repository browser.