Line data Source code
1 : module viscosity_mod
2 : !
3 : ! This module should be renamed "global_deriv_mod.F90"
4 : !
5 : ! It is a collection of derivative operators that must be applied to the field
6 : ! over the sphere (as opposed to derivative operators that can be applied element
7 : ! by element)
8 : !
9 : !
10 : use shr_kind_mod, only: r8=>shr_kind_r8
11 : use thread_mod, only: max_num_threads, omp_get_num_threads
12 : use dimensions_mod, only: np, nc, nlev,nlevp, qsize,nelemd
13 : use hybrid_mod, only: hybrid_t, get_loop_ranges, config_thread_region
14 : use parallel_mod, only: parallel_t
15 : use element_mod, only: element_t
16 : use derivative_mod, only: derivative_t, laplace_sphere_wk, vlaplace_sphere_wk, vorticity_sphere, derivinit, divergence_sphere
17 : use edgetype_mod, only: EdgeBuffer_t, EdgeDescriptor_t
18 : use edge_mod, only: edgevpack, edgevunpack, edgeVunpackmin, edgeSunpackmin, &
19 : edgeVunpackmax, initEdgeBuffer, FreeEdgeBuffer, edgeSunpackmax, edgeSpack
20 : use bndry_mod, only: bndry_exchange, bndry_exchange_start,bndry_exchange_finish
21 : use control_mod, only: hypervis_scaling, nu, nu_div
22 : use thread_mod, only: vert_num_threads
23 :
24 : implicit none
25 : save
26 :
27 : public :: biharmonic_wk_scalar
28 : public :: biharmonic_wk_omega
29 : public :: neighbor_minmax, neighbor_minmax_start,neighbor_minmax_finish
30 :
31 : !
32 : ! compute vorticity/divergence and then project to make continious
33 : ! high-level routines uses only for I/O
34 : public :: compute_zeta_C0
35 : public :: compute_div_C0
36 :
37 : interface compute_zeta_C0
38 : module procedure compute_zeta_C0_hybrid ! hybrid version
39 : module procedure compute_zeta_C0_par ! single threaded
40 : end interface compute_zeta_C0
41 : interface compute_div_C0
42 : module procedure compute_div_C0_hybrid
43 : module procedure compute_div_C0_par
44 : end interface compute_div_C0
45 :
46 : public :: compute_zeta_C0_contra ! for older versions of sweq which carry
47 : public :: compute_div_C0_contra ! velocity around in contra-coordinates
48 :
49 : type (EdgeBuffer_t) :: edge1
50 :
51 : CONTAINS
52 :
53 400896 : subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend)
54 : use derivative_mod, only : subcell_Laplace_fluxes
55 : use dimensions_mod, only : use_cslam, nu_div_lev,nu_lev
56 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
57 : ! compute weak biharmonic operator
58 : ! input: h,v (stored in elem()%, in lat-lon coordinates
59 : ! output: ttens,vtens overwritten with weak biharmonic of h,v (output in lat-lon coordinates)
60 : !
61 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
62 : type (hybrid_t) , intent(in) :: hybrid
63 : type (element_t) , intent(inout), target :: elem(:)
64 : integer , intent(in) :: nt,nets,nete
65 : integer , intent(in) :: kbeg, kend
66 : real (kind=r8), intent(out), dimension(nc,nc,4,nlev,nets:nete) :: dpflux
67 : real (kind=r8), dimension(np,np,2,nlev,nets:nete) :: vtens
68 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: ttens,dptens
69 : type (EdgeBuffer_t) , intent(inout) :: edge3
70 : type (derivative_t) , intent(in) :: deriv
71 : ! local
72 : integer :: i,j,k,kptr,ie,kblk
73 : ! real (kind=r8), dimension(:,:), pointer :: rspheremv
74 : real (kind=r8), dimension(np,np) :: tmp
75 : real (kind=r8), dimension(np,np) :: tmp2
76 : real (kind=r8), dimension(np,np,2) :: v
77 :
78 : real (kind=r8), dimension(np,np,nlev) :: lap_p_wk
79 : real (kind=r8), dimension(np,np,nlevp) :: T_i
80 :
81 :
82 : real (kind=r8) :: nu_ratio1, nu_ratio2
83 : logical var_coef1
84 :
85 400896 : kblk = kend - kbeg + 1
86 :
87 13897084896 : if (use_cslam) dpflux = 0
88 : !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad)
89 : !so tensor is only used on second call to laplace_sphere_wk
90 400896 : var_coef1 = .true.
91 400896 : if(hypervis_scaling > 0) var_coef1 = .false.
92 3219696 : do ie=nets,nete
93 : !$omp parallel do num_threads(vert_num_threads) private(k,tmp)
94 264967200 : do k=kbeg,kend
95 262148400 : nu_ratio1=1
96 262148400 : nu_ratio2=1
97 262148400 : if (nu_div_lev(k)/=nu_lev(k)) then
98 262148400 : if(hypervis_scaling /= 0) then
99 : ! we have a problem with the tensor in that we cant seperate
100 : ! div and curl components. So we do, with tensor V:
101 : ! nu * (del V del ) * ( nu_ratio * grad(div) - curl(curl))
102 0 : nu_ratio1=nu_div_lev(k)/nu_lev(k)
103 : nu_ratio2=1
104 : else
105 262148400 : nu_ratio1=sqrt(nu_div_lev(k)/nu_lev(k))
106 262148400 : nu_ratio2=sqrt(nu_div_lev(k)/nu_lev(k))
107 : endif
108 : endif
109 :
110 5505116400 : tmp=elem(ie)%state%T(:,:,k,nt)-elem(ie)%derived%T_ref(:,:,k)
111 262148400 : call laplace_sphere_wk(tmp,deriv,elem(ie),ttens(:,:,k,ie),var_coef=var_coef1)
112 :
113 5505116400 : tmp=elem(ie)%state%dp3d(:,:,k,nt)-elem(ie)%derived%dp_ref(:,:,k)
114 262148400 : call laplace_sphere_wk(tmp,deriv,elem(ie),dptens(:,:,k,ie),var_coef=var_coef1)
115 :
116 262148400 : call vlaplace_sphere_wk(elem(ie)%state%v(:,:,:,k,nt),deriv,elem(ie),.true.,vtens(:,:,:,k,ie), &
117 527115600 : var_coef=var_coef1,nu_ratio=nu_ratio1)
118 : enddo
119 :
120 2818800 : kptr = kbeg - 1
121 2818800 : call edgeVpack(edge3,ttens(:,:,kbeg:kend,ie),kblk,kptr,ie)
122 :
123 2818800 : kptr = kbeg - 1 + nlev
124 5507935200 : call edgeVpack(edge3,vtens(:,:,1,kbeg:kend,ie),kblk,kptr,ie)
125 :
126 2818800 : kptr = kbeg - 1 + 2*nlev
127 5507935200 : call edgeVpack(edge3,vtens(:,:,2,kbeg:kend,ie),kblk,kptr,ie)
128 :
129 2818800 : kptr = kbeg - 1 + 3*nlev
130 3219696 : call edgeVpack(edge3,dptens(:,:,kbeg:kend,ie),kblk,kptr,ie)
131 : enddo
132 :
133 400896 : call bndry_exchange(hybrid,edge3,location='biharmonic_wk_dp3d')
134 :
135 3219696 : do ie=nets,nete
136 : !CLEAN rspheremv => elem(ie)%rspheremp(:,:)
137 :
138 2818800 : kptr = kbeg - 1
139 2818800 : call edgeVunpack(edge3,ttens(:,:,kbeg:kend,ie),kblk,kptr,ie)
140 :
141 2818800 : kptr = kbeg - 1 + nlev
142 11013051600 : call edgeVunpack(edge3,vtens(:,:,1,kbeg:kend,ie),kblk,kptr,ie)
143 :
144 2818800 : kptr = kbeg - 1 + 2*nlev
145 11013051600 : call edgeVunpack(edge3,vtens(:,:,2,kbeg:kend,ie),kblk,kptr,ie)
146 :
147 2818800 : kptr = kbeg - 1 + 3*nlev
148 2818800 : call edgeVunpack(edge3,dptens(:,:,kbeg:kend,ie),kblk,kptr,ie)
149 :
150 2818800 : if (use_cslam) then
151 264967200 : do k=1,nlev
152 : !CLEAN tmp(:,:)= rspheremv(:,:)*dptens(:,:,k,ie)
153 5505116400 : tmp(:,:)= elem(ie)%rspheremp(:,:)*dptens(:,:,k,ie)
154 264967200 : call subcell_Laplace_fluxes(tmp, deriv, elem(ie), np, nc,dpflux(:,:,:,k,ie))
155 : enddo
156 : endif
157 :
158 : ! apply inverse mass matrix, then apply laplace again
159 : !$omp parallel do num_threads(vert_num_threads) private(k,v,tmp,tmp2)
160 265368096 : do k=kbeg,kend
161 : !CLEAN tmp(:,:)=rspheremv(:,:)*ttens(:,:,k,ie)
162 5505116400 : tmp(:,:)=elem(ie)%rspheremp(:,:)*ttens(:,:,k,ie)
163 262148400 : call laplace_sphere_wk(tmp,deriv,elem(ie),ttens(:,:,k,ie),var_coef=.true.)
164 : !CLEAN tmp2(:,:)=rspheremv(:,:)*dptens(:,:,k,ie)
165 5505116400 : tmp2(:,:)=elem(ie)%rspheremp(:,:)*dptens(:,:,k,ie)
166 262148400 : call laplace_sphere_wk(tmp2,deriv,elem(ie),dptens(:,:,k,ie),var_coef=.true.)
167 : !CLEAN v(:,:,1)=rspheremv(:,:)*vtens(:,:,1,k,ie)
168 : !CLEAN v(:,:,2)=rspheremv(:,:)*vtens(:,:,2,k,ie)
169 :
170 5505116400 : v(:,:,1)=elem(ie)%rspheremp(:,:)*vtens(:,:,1,k,ie)
171 5505116400 : v(:,:,2)=elem(ie)%rspheremp(:,:)*vtens(:,:,2,k,ie)
172 : call vlaplace_sphere_wk(v(:,:,:),deriv,elem(ie),.true.,vtens(:,:,:,k,ie), &
173 264967200 : var_coef=.true.,nu_ratio=nu_ratio2)
174 :
175 : enddo
176 : enddo
177 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
178 400896 : end subroutine biharmonic_wk_dp3d
179 :
180 :
181 73728 : subroutine biharmonic_wk_omega(elem,ptens,deriv,edge3,hybrid,nets,nete,kbeg,kend)
182 : type (hybrid_t) , intent(in) :: hybrid
183 : type (element_t) , intent(inout), target :: elem(:)
184 : integer , intent(in) :: nets,nete
185 : integer , intent(in) :: kbeg, kend
186 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: ptens
187 : type (EdgeBuffer_t) , intent(inout) :: edge3
188 : type (derivative_t) , intent(in) :: deriv
189 :
190 : ! local
191 : integer :: i,j,k,kptr,ie,kblk
192 73728 : real (kind=r8), dimension(:,:), pointer :: rspheremv
193 : real (kind=r8), dimension(np,np) :: tmp
194 : real (kind=r8), dimension(np,np) :: tmp2
195 : real (kind=r8), dimension(np,np,2) :: v
196 : real (kind=r8) :: nu_ratio1, nu_ratio2
197 : logical var_coef1
198 :
199 73728 : kblk = kend - kbeg + 1
200 :
201 : !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad)
202 : !so tensor is only used on second call to laplace_sphere_wk
203 73728 : var_coef1 = .true.
204 0 : if(hypervis_scaling > 0) var_coef1 = .false.
205 :
206 73728 : nu_ratio1=1
207 73728 : nu_ratio2=1
208 :
209 592128 : do ie=nets,nete
210 :
211 : !$omp parallel do num_threads(vert_num_threads) private(k,tmp)
212 48729600 : do k=kbeg,kend
213 1012435200 : tmp=elem(ie)%derived%omega(:,:,k)
214 48729600 : call laplace_sphere_wk(tmp,deriv,elem(ie),ptens(:,:,k,ie),var_coef=var_coef1)
215 : enddo
216 :
217 518400 : kptr = kbeg - 1
218 592128 : call edgeVpack(edge3,ptens(:,:,kbeg:kend,ie),kblk,kptr,ie)
219 : enddo
220 :
221 73728 : call bndry_exchange(hybrid,edge3,location='biharmonic_wk_omega')
222 :
223 592128 : do ie=nets,nete
224 518400 : rspheremv => elem(ie)%rspheremp(:,:)
225 :
226 518400 : kptr = kbeg - 1
227 518400 : call edgeVunpack(edge3,ptens(:,:,kbeg:kend,ie),kblk,kptr,ie)
228 :
229 : ! apply inverse mass matrix, then apply laplace again
230 : !$omp parallel do num_threads(vert_num_threads) private(k,tmp)
231 48803328 : do k=kbeg,kend
232 1012435200 : tmp(:,:)=rspheremv(:,:)*ptens(:,:,k,ie)
233 48729600 : call laplace_sphere_wk(tmp,deriv,elem(ie),ptens(:,:,k,ie),var_coef=.true.)
234 : enddo
235 : enddo
236 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
237 474624 : end subroutine biharmonic_wk_omega
238 :
239 :
240 0 : subroutine biharmonic_wk_scalar(elem,qtens,deriv,edgeq,hybrid,nets,nete)
241 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
242 : ! compute weak biharmonic operator
243 : ! input: qtens = Q
244 : ! output: qtens = weak biharmonic of Q
245 : !
246 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
247 : type (hybrid_t) , intent(in) :: hybrid
248 : type (element_t) , intent(inout), target :: elem(:)
249 : integer :: nets,nete
250 : real (kind=r8), dimension(np,np,nlev,qsize,nets:nete) :: qtens
251 : type (EdgeBuffer_t) , intent(inout) :: edgeq
252 : type (derivative_t) , intent(in) :: deriv
253 :
254 : ! local
255 : integer :: k,kptr,i,j,ie,ic,q
256 : integer :: kbeg,kend,qbeg,qend
257 : real (kind=r8), dimension(np,np) :: lap_p
258 : logical var_coef1
259 : integer :: kblk,qblk ! The per thead size of the vertical and tracers
260 :
261 0 : call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend)
262 :
263 : !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad)
264 : !so tensor is only used on second call to laplace_sphere_wk
265 0 : var_coef1 = .true.
266 0 : if(hypervis_scaling > 0) var_coef1 = .false.
267 :
268 :
269 0 : kblk = kend - kbeg + 1 ! calculate size of the block of vertical levels
270 0 : qblk = qend - qbeg + 1 ! calculate size of the block of tracers
271 :
272 0 : do ie=nets,nete
273 0 : do q=qbeg,qend
274 0 : do k=kbeg,kend
275 0 : lap_p(:,:)=qtens(:,:,k,q,ie)
276 0 : call laplace_sphere_wk(lap_p,deriv,elem(ie),qtens(:,:,k,q,ie),var_coef=var_coef1)
277 : enddo
278 0 : kptr = nlev*(q-1) + kbeg - 1
279 0 : call edgeVpack(edgeq, qtens(:,:,kbeg:kend,q,ie),kblk,kptr,ie)
280 : enddo
281 : enddo
282 :
283 :
284 0 : call bndry_exchange(hybrid,edgeq,location='biharmonic_wk_scalar')
285 :
286 0 : do ie=nets,nete
287 :
288 : ! apply inverse mass matrix, then apply laplace again
289 0 : do q=qbeg,qend
290 0 : kptr = nlev*(q-1) + kbeg - 1
291 0 : call edgeVunpack(edgeq, qtens(:,:,kbeg:kend,q,ie),kblk,kptr,ie)
292 0 : do k=kbeg,kend
293 0 : lap_p(:,:)=elem(ie)%rspheremp(:,:)*qtens(:,:,k,q,ie)
294 0 : call laplace_sphere_wk(lap_p,deriv,elem(ie),qtens(:,:,k,q,ie),var_coef=.true.)
295 : enddo
296 : enddo
297 : enddo
298 :
299 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
300 0 : end subroutine biharmonic_wk_scalar
301 :
302 :
303 0 : subroutine make_C0(zeta,elem,hybrid,nets,nete)
304 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
305 : ! apply DSS (aka assembly procedure) to zeta.
306 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
307 :
308 : type (hybrid_t) , intent(in) :: hybrid
309 : type (element_t) , intent(in), target :: elem(:)
310 : integer :: nets,nete
311 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: zeta
312 :
313 : ! local
314 : integer :: k,i,j,ie,ic,kptr,nthread_save
315 :
316 :
317 0 : call initEdgeBuffer(hybrid%par,edge1,elem,nlev)
318 :
319 0 : do ie=nets,nete
320 : #if (defined COLUMN_OPENMP)
321 : !$omp parallel do num_threads(vert_num_threads) private(k)
322 : #endif
323 0 : do k=1,nlev
324 0 : zeta(:,:,k,ie)=zeta(:,:,k,ie)*elem(ie)%spheremp(:,:)
325 : enddo
326 0 : kptr=0
327 0 : call edgeVpack(edge1, zeta(1,1,1,ie),nlev,kptr,ie)
328 : enddo
329 0 : call bndry_exchange(hybrid,edge1,location='make_C0')
330 0 : do ie=nets,nete
331 0 : kptr=0
332 0 : call edgeVunpack(edge1, zeta(1,1,1,ie),nlev,kptr, ie)
333 : #if (defined COLUMN_OPENMP)
334 : !$omp parallel do num_threads(vert_num_threads) private(k)
335 : #endif
336 0 : do k=1,nlev
337 0 : zeta(:,:,k,ie)=zeta(:,:,k,ie)*elem(ie)%rspheremp(:,:)
338 : enddo
339 : enddo
340 :
341 0 : call FreeEdgeBuffer(edge1)
342 :
343 0 : end subroutine
344 :
345 :
346 0 : subroutine make_C0_vector(v,elem,hybrid,nets,nete)
347 : #if 1
348 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
349 : ! apply DSS to a velocity vector
350 : ! this is a low-performance routine used for I/O and analysis.
351 : ! no need to optimize
352 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
353 : type (hybrid_t) , intent(in) :: hybrid
354 : type (element_t) , intent(in), target :: elem(:)
355 : integer :: nets,nete
356 : real (kind=r8), dimension(np,np,2,nlev,nets:nete) :: v
357 :
358 : ! local
359 : integer :: k,i,j,ie,ic,kptr
360 : type (EdgeBuffer_t) :: edge2
361 0 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: v1
362 :
363 0 : v1(:,:,:,:) = v(:,:,1,:,:)
364 0 : call make_C0(v1,elem,hybrid,nets,nete)
365 0 : v(:,:,1,:,:) = v1(:,:,:,:)
366 :
367 0 : v1(:,:,:,:) = v(:,:,2,:,:)
368 0 : call make_C0(v1,elem,hybrid,nets,nete)
369 0 : v(:,:,2,:,:) = v1(:,:,:,:)
370 : #else
371 : type (hybrid_t) , intent(in) :: hybrid
372 : type (element_t) , intent(in), target :: elem(:)
373 : integer :: nets,nete
374 : real (kind=r8), dimension(np,np,2,nlev,nets:nete) :: v
375 :
376 : ! local
377 : integer :: k,i,j,ie,ic,kptr
378 : type (EdgeBuffer_t) :: edge2
379 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: v1
380 :
381 :
382 :
383 : call initEdgeBuffer(hybrid%par,edge2,elem,2*nlev)
384 :
385 : do ie=nets,nete
386 : #if (defined COLUMN_OPENMP)
387 : !$omp parallel do num_threads(vert_num_threads) private(k)
388 : #endif
389 : do k=1,nlev
390 : v(:,:,1,k,ie)=v(:,:,1,k,ie)*elem(ie)%spheremp(:,:)
391 : v(:,:,2,k,ie)=v(:,:,2,k,ie)*elem(ie)%spheremp(:,:)
392 : enddo
393 : kptr=0
394 : call edgeVpack(edge2, v(1,1,1,1,ie),2*nlev,kptr,ie)
395 : enddo
396 : call bndry_exchange(hybrid,edge2,location='make_C0_vector')
397 : do ie=nets,nete
398 : kptr=0
399 : call edgeVunpack(edge2, v(1,1,1,1,ie),2*nlev,kptr,ie)
400 : #if (defined COLUMN_OPENMP)
401 : !$omp parallel do num_threads(vert_num_threads) private(k)
402 : #endif
403 : do k=1,nlev
404 : v(:,:,1,k,ie)=v(:,:,1,k,ie)*elem(ie)%rspheremp(:,:)
405 : v(:,:,2,k,ie)=v(:,:,2,k,ie)*elem(ie)%rspheremp(:,:)
406 : enddo
407 : enddo
408 :
409 : call FreeEdgeBuffer(edge2)
410 : #endif
411 0 : end subroutine
412 :
413 :
414 :
415 :
416 :
417 :
418 0 : subroutine compute_zeta_C0_contra(zeta,elem,hybrid,nets,nete,nt)
419 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
420 : ! compute C0 vorticity. That is, solve:
421 : ! < PHI, zeta > = <PHI, curl(elem%state%v >
422 : !
423 : ! input: v (stored in elem()%, in contra-variant coordinates)
424 : ! output: zeta(:,:,:,:)
425 : !
426 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
427 :
428 : type (hybrid_t) , intent(in) :: hybrid
429 : type (element_t) , intent(in), target :: elem(:)
430 : integer :: nt,nets,nete
431 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: zeta
432 : real (kind=r8), dimension(np,np,2) :: ulatlon
433 : real (kind=r8), dimension(np,np) :: v1,v2
434 :
435 : ! local
436 : integer :: k,ie
437 : type (derivative_t) :: deriv
438 :
439 0 : call derivinit(deriv)
440 :
441 0 : do k=1,nlev
442 0 : do ie=nets,nete
443 0 : v1 = elem(ie)%state%v(:,:,1,k,nt)
444 0 : v2 = elem(ie)%state%v(:,:,2,k,nt)
445 0 : ulatlon(:,:,1) = elem(ie)%D(:,:,1,1)*v1 + elem(ie)%D(:,:,1,2)*v2
446 0 : ulatlon(:,:,2) = elem(ie)%D(:,:,2,1)*v1 + elem(ie)%D(:,:,2,2)*v2
447 0 : call vorticity_sphere(ulatlon,deriv,elem(ie),zeta(:,:,k,ie))
448 : enddo
449 : enddo
450 :
451 0 : call make_C0(zeta,elem,hybrid,nets,nete)
452 :
453 0 : end subroutine
454 :
455 :
456 :
457 0 : subroutine compute_div_C0_contra(zeta,elem,hybrid,nets,nete,nt)
458 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
459 : ! compute C0 divergence. That is, solve:
460 : ! < PHI, zeta > = <PHI, div(elem%state%v >
461 : !
462 : ! input: v (stored in elem()%, in contra-variant coordinates)
463 : ! output: zeta(:,:,:,:)
464 : !
465 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
466 :
467 : type (hybrid_t) , intent(in) :: hybrid
468 : type (element_t) , intent(in), target :: elem(:)
469 : integer :: nt,nets,nete
470 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: zeta
471 : real (kind=r8), dimension(np,np,2) :: ulatlon
472 : real (kind=r8), dimension(np,np) :: v1,v2
473 :
474 : ! local
475 : integer :: k,ie
476 : type (derivative_t) :: deriv
477 :
478 0 : call derivinit(deriv)
479 :
480 0 : do k=1,nlev
481 0 : do ie=nets,nete
482 0 : v1 = elem(ie)%state%v(:,:,1,k,nt)
483 0 : v2 = elem(ie)%state%v(:,:,2,k,nt)
484 0 : ulatlon(:,:,1) = elem(ie)%D(:,:,1,1)*v1 + elem(ie)%D(:,:,1,2)*v2
485 0 : ulatlon(:,:,2) = elem(ie)%D(:,:,2,1)*v1 + elem(ie)%D(:,:,2,2)*v2
486 0 : call divergence_sphere(ulatlon,deriv,elem(ie),zeta(:,:,k,ie))
487 : enddo
488 : enddo
489 :
490 0 : call make_C0(zeta,elem,hybrid,nets,nete)
491 :
492 0 : end subroutine
493 :
494 0 : subroutine compute_zeta_C0_par(zeta,elem,par,nt)
495 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
496 : ! compute C0 vorticity. That is, solve:
497 : ! < PHI, zeta > = <PHI, curl(elem%state%v >
498 : !
499 : ! input: v (stored in elem()%, in lat-lon coordinates)
500 : ! output: zeta(:,:,:,:)
501 : !
502 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
503 : type (parallel_t) :: par
504 : type (element_t) , intent(in), target :: elem(:)
505 : real (kind=r8), dimension(np,np,nlev,nelemd) :: zeta
506 : integer :: nt
507 :
508 : ! local
509 : type (hybrid_t) :: hybrid
510 : integer :: k,i,j,ie,ic
511 : type (derivative_t) :: deriv
512 :
513 : ! single thread
514 0 : hybrid = config_thread_region(par,'serial')
515 :
516 0 : call compute_zeta_C0_hybrid(zeta,elem,hybrid,1,nelemd,nt)
517 :
518 0 : end subroutine
519 :
520 :
521 0 : subroutine compute_div_C0_par(zeta,elem,par,nt)
522 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
523 : ! compute C0 divergence. That is, solve:
524 : ! < PHI, zeta > = <PHI, div(elem%state%v >
525 : !
526 : ! input: v (stored in elem()%, in lat-lon coordinates)
527 : ! output: zeta(:,:,:,:)
528 : !
529 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
530 :
531 : type (parallel_t) :: par
532 : type (element_t) , intent(in), target :: elem(:)
533 : real (kind=r8), dimension(np,np,nlev,nelemd) :: zeta
534 : integer :: nt
535 :
536 : ! local
537 : type (hybrid_t) :: hybrid
538 : integer :: k,i,j,ie,ic
539 : type (derivative_t) :: deriv
540 :
541 : ! single thread
542 0 : hybrid = config_thread_region(par,'serial')
543 :
544 0 : call compute_div_C0_hybrid(zeta,elem,hybrid,1,nelemd,nt)
545 :
546 0 : end subroutine
547 :
548 :
549 :
550 0 : subroutine compute_zeta_C0_hybrid(zeta,elem,hybrid,nets,nete,nt)
551 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
552 : ! compute C0 vorticity. That is, solve:
553 : ! < PHI, zeta > = <PHI, curl(elem%state%v >
554 : !
555 : ! input: v (stored in elem()%, in lat-lon coordinates)
556 : ! output: zeta(:,:,:,:)
557 : !
558 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
559 :
560 : type (hybrid_t) , intent(in) :: hybrid
561 : type (element_t) , intent(in), target :: elem(:)
562 : integer :: nt,nets,nete
563 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: zeta
564 :
565 : ! local
566 : integer :: k,i,j,ie,ic
567 : type (derivative_t) :: deriv
568 :
569 0 : call derivinit(deriv)
570 :
571 0 : do ie=nets,nete
572 : #if (defined COLUMN_OPENMP)
573 : !$omp parallel do num_threads(vert_num_threads) private(k)
574 : #endif
575 0 : do k=1,nlev
576 0 : call vorticity_sphere(elem(ie)%state%v(:,:,:,k,nt),deriv,elem(ie),zeta(:,:,k,ie))
577 : enddo
578 : enddo
579 :
580 0 : call make_C0(zeta,elem,hybrid,nets,nete)
581 :
582 0 : end subroutine
583 :
584 :
585 0 : subroutine compute_div_C0_hybrid(zeta,elem,hybrid,nets,nete,nt)
586 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
587 : ! compute C0 divergence. That is, solve:
588 : ! < PHI, zeta > = <PHI, div(elem%state%v >
589 : !
590 : ! input: v (stored in elem()%, in lat-lon coordinates)
591 : ! output: zeta(:,:,:,:)
592 : !
593 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
594 :
595 : type (hybrid_t) , intent(in) :: hybrid
596 : type (element_t) , intent(in), target :: elem(:)
597 : integer :: nt,nets,nete
598 : real (kind=r8), dimension(np,np,nlev,nets:nete) :: zeta
599 :
600 : ! local
601 : integer :: k,i,j,ie,ic
602 : type (derivative_t) :: deriv
603 :
604 0 : call derivinit(deriv)
605 :
606 0 : do ie=nets,nete
607 : #if (defined COLUMN_OPENMP)
608 : !$omp parallel do num_threads(vert_num_threads) private(k)
609 : #endif
610 0 : do k=1,nlev
611 0 : call divergence_sphere(elem(ie)%state%v(:,:,:,k,nt),deriv,elem(ie),zeta(:,:,k,ie))
612 : enddo
613 : enddo
614 :
615 0 : call make_C0(zeta,elem,hybrid,nets,nete)
616 :
617 0 : end subroutine
618 :
619 :
620 :
621 :
622 :
623 :
624 :
625 :
626 0 : subroutine neighbor_minmax(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh)
627 :
628 : type (hybrid_t) , intent(in) :: hybrid
629 : type (EdgeBuffer_t) , intent(inout) :: edgeMinMax
630 : integer :: nets,nete
631 : real (kind=r8) :: min_neigh(nlev,qsize,nets:nete)
632 : real (kind=r8) :: max_neigh(nlev,qsize,nets:nete)
633 : integer :: kblk, qblk
634 : ! local
635 : integer:: ie, q, k, kptr
636 : integer:: kbeg, kend, qbeg, qend
637 :
638 0 : call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend)
639 :
640 0 : kblk = kend - kbeg + 1 ! calculate size of the block of vertical levels
641 0 : qblk = qend - qbeg + 1 ! calculate size of the block of tracers
642 :
643 0 : do ie=nets,nete
644 0 : do q = qbeg, qend
645 0 : kptr = nlev*(q - 1) + kbeg - 1
646 0 : call edgeSpack(edgeMinMax,min_neigh(kbeg:kend,q,ie),kblk,kptr,ie)
647 0 : kptr = qsize*nlev + nlev*(q - 1) + kbeg - 1
648 0 : call edgeSpack(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie)
649 : enddo
650 : enddo
651 :
652 0 : call bndry_exchange(hybrid,edgeMinMax,location='neighbor_minmax')
653 :
654 0 : do ie=nets,nete
655 0 : do q=qbeg,qend
656 0 : kptr = nlev*(q - 1) + kbeg - 1
657 0 : call edgeSunpackMIN(edgeMinMax,min_neigh(kbeg:kend,q,ie),kblk,kptr,ie)
658 0 : kptr = qsize*nlev + nlev*(q - 1) + kbeg - 1
659 0 : call edgeSunpackMAX(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie)
660 0 : do k=kbeg,kend
661 0 : min_neigh(k,q,ie) = max(min_neigh(k,q,ie),0.0_r8)
662 : enddo
663 : enddo
664 : enddo
665 :
666 0 : end subroutine neighbor_minmax
667 :
668 :
669 0 : subroutine neighbor_minmax_start(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh)
670 :
671 : type (hybrid_t) , intent(in) :: hybrid
672 : type (EdgeBuffer_t) , intent(inout) :: edgeMinMax
673 : integer :: nets,nete
674 : real (kind=r8) :: min_neigh(nlev,qsize,nets:nete)
675 : real (kind=r8) :: max_neigh(nlev,qsize,nets:nete)
676 : integer :: kblk, qblk
677 : integer :: kbeg, kend, qbeg, qend
678 :
679 : ! local
680 : integer :: ie,q, k,kptr
681 :
682 0 : call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend)
683 :
684 0 : kblk = kend - kbeg + 1 ! calculate size of the block of vertical levels
685 0 : qblk = qend - qbeg + 1 ! calculate size of the block of tracers
686 :
687 0 : do ie=nets,nete
688 0 : do q=qbeg, qend
689 0 : kptr = nlev*(q - 1) + kbeg - 1
690 0 : call edgeSpack(edgeMinMax,min_neigh(kbeg:kend,q,ie),kblk,kptr,ie)
691 0 : kptr = qsize*nlev + nlev*(q - 1) + kbeg - 1
692 0 : call edgeSpack(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie)
693 : enddo
694 : enddo
695 :
696 0 : call bndry_exchange_start(hybrid,edgeMinMax,location='neighbor_minmax_start')
697 :
698 0 : end subroutine neighbor_minmax_start
699 :
700 0 : subroutine neighbor_minmax_finish(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh)
701 :
702 : type (hybrid_t) , intent(in) :: hybrid
703 : type (EdgeBuffer_t) , intent(inout) :: edgeMinMax
704 : integer :: nets,nete
705 : real (kind=r8) :: min_neigh(nlev,qsize,nets:nete)
706 : real (kind=r8) :: max_neigh(nlev,qsize,nets:nete)
707 : integer :: kblk, qblk
708 : integer :: ie,q, k,kptr
709 : integer :: kbeg, kend, qbeg, qend
710 :
711 0 : call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend)
712 :
713 0 : kblk = kend - kbeg + 1 ! calculate size of the block of vertical levels
714 0 : qblk = qend - qbeg + 1 ! calculate size of the block of tracers
715 :
716 0 : call bndry_exchange_finish(hybrid,edgeMinMax,location='neighbor_minmax_finish')
717 :
718 0 : do ie=nets,nete
719 0 : do q=qbeg, qend
720 0 : kptr = nlev*(q - 1) + kbeg - 1
721 0 : call edgeSunpackMIN(edgeMinMax,min_neigh(kbeg:kend,q,ie),kblk,kptr,ie)
722 0 : kptr = qsize*nlev + nlev*(q - 1) + kbeg - 1
723 0 : call edgeSunpackMAX(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie)
724 0 : do k=kbeg,kend
725 0 : min_neigh(k,q,ie) = max(min_neigh(k,q,ie),0.0_r8)
726 : enddo
727 : enddo
728 : enddo
729 :
730 0 : end subroutine neighbor_minmax_finish
731 :
732 : end module viscosity_mod
|