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

Last change on this file since 5160 was 5160, checked in by abarral, 7 weeks ago

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