source: LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.F90 @ 5267

Last change on this file since 5267 was 5258, checked in by abarral, 3 days ago

Wrap uses of cpp key DEBUG_IO
  • 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: 8.9 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
19
20CONTAINS
21 
22  SUBROUTINE call_dissip_allocate
23  USE bands
24  USE allocate_field_mod
25  USE parallel_lmdz
26  USE dimensions_mod
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   
49    CALL dissip_allocate
50   
51  END SUBROUTINE call_dissip_allocate
52 
53  SUBROUTINE call_dissip_switch_dissip(dist)
54  USE allocate_field_mod
55  USE bands
56  USE parallel_lmdz
57  USE dissip_mod, ONLY : dissip_switch_dissip
58  IMPLICIT NONE
59    TYPE(distrib),INTENT(IN) :: dist
60
61    CALL switch_u(ucov,distrib_dissip,dist)
62    CALL switch_v(vcov,distrib_dissip,dist)
63    CALL switch_u(teta,distrib_dissip,dist)
64    CALL switch_u(p,distrib_dissip,dist)
65    CALL switch_u(pk,distrib_dissip,dist)
66    CALL switch_u(ucont,distrib_dissip,dist)
67    CALL switch_v(vcont,distrib_dissip,dist)
68    CALL switch_u(ecin,distrib_dissip,dist)
69    CALL switch_u(ecin0,distrib_dissip,dist)
70    CALL switch_u(dudis,distrib_dissip,dist)
71    CALL switch_v(dvdis,distrib_dissip,dist)
72    CALL switch_u(dtetadis,distrib_dissip,dist)
73    CALL switch_u(dtetaecdt,distrib_dissip,dist)
74
75    CALL dissip_switch_dissip(dist)
76   
77  END SUBROUTINE call_dissip_switch_dissip 
78 
79
80 
81  SUBROUTINE call_dissip(ucov_dyn,vcov_dyn,teta_dyn,p_dyn,pk_dyn,ps_dyn)
82  USE dimensions_mod
83  USE parallel_lmdz
84  USE times
85  USE mod_hallo
86  USE Bands
87  USE vampir
88  USE write_field_loc
89  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
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    REAL  SSUM
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
147IF (CPPKEY_DEBUGIO) THEN
148    CALL WriteField_u('dudis',dudis)
149    CALL WriteField_v('dvdis',dvdis)
150    CALL WriteField_u('dtetadis',dtetadis)
151END 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
227    ijb=ij_begin
228    ije=ij_end
229         
230    IF (pole_nord) THEN
231 
232   !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
233      DO l  =  1, llm
234        DO ij =  1,iim
235          tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
236        ENDDO
237        tpn  = SSUM(iim,tppn,1)/apoln
238
239        DO ij = 1, iip1
240          teta(  ij    ,l) = tpn
241        ENDDO
242      ENDDO
243    !$OMP END DO NOWAIT
244
245         if (1 == 0) then
246!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
247!!!                     2) should probably not be here anyway
248!!! but are kept for those who would want to revert to previous behaviour
249    !$OMP MASTER               
250      DO ij =  1,iim
251        tppn(ij)  = aire(  ij    ) * ps_dyn (  ij    )
252      ENDDO
253      tpn  = SSUM(iim,tppn,1)/apoln
254 
255      DO ij = 1, iip1
256        ps_dyn(  ij    ) = tpn
257      ENDDO
258    !$OMP END MASTER
259   
260    ENDIF ! of if (1 == 0)
261    endif ! of of (pole_nord)
262       
263    IF (pole_sud) THEN
264
265    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
266      DO l  =  1, llm
267        DO ij =  1,iim
268          tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
269        ENDDO
270       
271        tps  = SSUM(iim,tpps,1)/apols
272
273        DO ij = 1, iip1
274          teta(ij+ip1jm,l) = tps
275        ENDDO
276      ENDDO
277    !$OMP END DO NOWAIT
278
279    if (1 == 0) then
280!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
281!!!                     2) should probably not be here anyway
282!!! but are kept for those who would want to revert to previous behaviour
283    !$OMP MASTER               
284      DO ij =  1,iim
285        tpps(ij)  = aire(ij+ip1jm) * ps_dyn (ij+ip1jm)
286      ENDDO
287      tps  = SSUM(iim,tpps,1)/apols
288 
289      DO ij = 1, iip1
290        ps_dyn(ij+ip1jm) = tps
291      ENDDO
292    !$OMP END MASTER
293    ENDIF ! of if (1 == 0)
294    endif ! of if (pole_sud)
295
296
297  !$OMP BARRIER
298  !$OMP MASTER
299    CALL VTe(VTdissipation)
300    CALL stop_timer(timer_dissip)
301    CALL VTb(VThallo)
302  !$OMP END MASTER
303 
304    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_dissip)
305    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_dissip)
306    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_dissip)
307    CALL Register_SwapField_u(p,p_dyn,distrib_caldyn,Request_dissip)
308    CALL Register_SwapField_u(pk,pk_dyn,distrib_caldyn,Request_dissip)
309
310    CALL SendRequest(Request_dissip)       
311
312  !$OMP BARRIER
313    CALL WaitRequest(Request_dissip)       
314  !$OMP BARRIER
315  !$OMP MASTER
316    CALL set_distrib(distrib_caldyn)
317    CALL VTe(VThallo)
318    CALL resume_timer(timer_caldyn)
319!        print *,'fin dissipation'
320  !$OMP END MASTER
321  !$OMP BARRIER
322 
323 
324  END SUBROUTINE call_dissip
325
326END MODULE call_dissip_mod
Note: See TracBrowser for help on using the repository browser.