Line data Source code
1 : module prim_init
2 :
3 : use shr_kind_mod, only: r8=>shr_kind_r8
4 : use dimensions_mod, only: nc
5 : use reduction_mod, only: reductionbuffer_ordered_1d_t
6 : use quadrature_mod, only: quadrature_t, gausslobatto
7 :
8 : implicit none
9 : private
10 : save
11 :
12 : public :: prim_init1
13 :
14 : real(r8), public :: fvm_corners(nc+1) ! fvm cell corners on reference element
15 : real(r8), public :: fvm_points(nc) ! fvm cell centers on reference element
16 :
17 : type (quadrature_t), public :: gp ! element GLL points
18 : type (ReductionBuffer_ordered_1d_t) :: red ! reduction buffer (shared)
19 :
20 : contains
21 2304 : subroutine prim_init1(elem, fvm, par, Tl)
22 : use cam_logfile, only: iulog
23 : use shr_sys_mod, only: shr_sys_flush
24 : use thread_mod, only: max_num_threads
25 : use dimensions_mod, only: np, nlev, nelem, nelemd, nelemdmax, qsize_d
26 : use dimensions_mod, only: GlobalUniqueCols, fv_nphys,irecons_tracer
27 : use control_mod, only: topology, partmethod
28 : use element_mod, only: element_t, allocate_element_desc
29 : use fvm_mod, only: fvm_init1
30 : use mesh_mod, only: MeshUseMeshFile
31 : use se_dyn_time_mod, only: timelevel_init, timelevel_t
32 : use mass_matrix_mod, only: mass_matrix
33 : use derivative_mod, only: allocate_subcell_integration_matrix_cslam
34 : use derivative_mod, only: allocate_subcell_integration_matrix_physgrid
35 : use cube_mod, only: cubeedgecount , cubeelemcount, cubetopology
36 : use cube_mod, only: cube_init_atomic, rotation_init_atomic, set_corner_coordinates
37 : use cube_mod, only: assign_node_numbers_to_elem
38 : use mesh_mod, only: MeshSetCoordinates, MeshUseMeshFile, MeshCubeTopology
39 : use mesh_mod, only: MeshCubeElemCount, MeshCubeEdgeCount
40 : use metagraph_mod, only: metavertex_t, localelemcount, initmetagraph, printmetavertex
41 : use gridgraph_mod, only: gridvertex_t, gridedge_t
42 : use gridgraph_mod, only: allocate_gridvertex_nbrs, deallocate_gridvertex_nbrs
43 : use schedtype_mod, only: schedule
44 : use schedule_mod, only: genEdgeSched
45 : use prim_advection_mod, only: prim_advec_init1
46 : use cam_abortutils, only: endrun
47 : use spmd_utils, only: mpi_integer, mpi_max
48 : use parallel_mod, only: parallel_t, syncmp, global_shared_buf, nrepro_vars
49 : use spacecurve_mod, only: genspacepart
50 : use dof_mod, only: global_dof, CreateUniqueIndex, SetElemOffset
51 : use params_mod, only: SFCURVE
52 : use physconst, only: pi
53 : use reduction_mod, only: red_min, red_max, red_max_int, red_flops
54 : use reduction_mod, only: red_sum, red_sum_int, initreductionbuffer
55 : use infnan, only: nan, assignment(=)
56 : use shr_reprosum_mod, only: repro_sum => shr_reprosum_calc
57 : use fvm_analytic_mod, only: compute_basic_coordinate_vars
58 : use fvm_control_volume_mod, only: fvm_struct, allocate_physgrid_vars
59 : use air_composition, only: thermodynamic_active_species_num
60 :
61 : type(element_t), pointer :: elem(:)
62 : type(fvm_struct), pointer :: fvm(:)
63 : type(parallel_t), intent(inout) :: par
64 : type(timelevel_t), intent(out) :: Tl
65 :
66 : ! Local Variables
67 2304 : type (GridVertex_t), target,allocatable :: GridVertex(:)
68 2304 : type (GridEdge_t), target,allocatable :: Gridedge(:)
69 2304 : type (MetaVertex_t), target,allocatable :: MetaVertex(:)
70 :
71 : integer :: ie
72 : integer :: nets, nete
73 : integer :: nelem_edge
74 : integer :: ierr=0, j
75 : logical, parameter :: Debug = .FALSE.
76 :
77 2304 : real(r8), allocatable :: aratio(:,:)
78 : real(r8) :: area(1), xtmp
79 : character(len=80) :: rot_type ! cube edge rotation type
80 :
81 : integer :: i
82 :
83 : character(len=128) :: errmsg
84 : character(len=*), parameter :: subname = 'PRIM_INIT1: '
85 :
86 : ! ====================================
87 : ! Set cube edge rotation type for model
88 : ! unnecessary complication here: all should
89 : ! be on the same footing. RDL
90 : ! =====================================
91 2304 : rot_type = "contravariant"
92 :
93 : ! ===============================================================
94 : ! Allocate and initialize the graph (array of GridVertex_t types)
95 : ! ===============================================================
96 :
97 2304 : if (topology=="cube") then
98 :
99 2304 : if (par%masterproc) then
100 3 : write(iulog,*) subname, "creating cube topology..."
101 3 : call shr_sys_flush(iulog)
102 : end if
103 :
104 2304 : if (MeshUseMeshFile) then
105 0 : nelem = MeshCubeElemCount()
106 0 : nelem_edge = MeshCubeEdgeCount()
107 : else
108 2304 : nelem = CubeElemCount()
109 2304 : nelem_edge = CubeEdgeCount()
110 : end if
111 :
112 12448512 : allocate(GridVertex(nelem))
113 99484416 : allocate(GridEdge(nelem_edge))
114 :
115 12443904 : do j = 1, nelem
116 12443904 : call allocate_gridvertex_nbrs(GridVertex(j))
117 : end do
118 :
119 2304 : if (MeshUseMeshFile) then
120 0 : if (par%masterproc) then
121 0 : write(iulog,*) subname, "Set up grid vertex from mesh..."
122 : end if
123 0 : call MeshCubeTopology(GridEdge, GridVertex)
124 : else
125 2304 : call CubeTopology(GridEdge,GridVertex)
126 : end if
127 :
128 2304 : if (par%masterproc) then
129 3 : write(iulog,*)"...done."
130 : end if
131 : end if
132 2304 : if(par%masterproc) then
133 3 : write(iulog,*) subname, "total number of elements nelem = ",nelem
134 : end if
135 :
136 2304 : if(partmethod == SFCURVE) then
137 2304 : if(par%masterproc) then
138 3 : write(iulog,*) subname, "partitioning graph using SF Curve..."
139 : end if
140 2304 : call genspacepart(GridVertex)
141 : else
142 0 : write(errmsg, *) 'Unsupported partition method, ',partmethod
143 0 : call endrun(subname//trim(errmsg))
144 : end if
145 :
146 : ! ===========================================================
147 : ! given partition, count number of local element descriptors
148 : ! ===========================================================
149 2304 : allocate(MetaVertex(1))
150 2304 : allocate(Schedule(1))
151 :
152 2304 : nelem_edge = SIZE(GridEdge)
153 :
154 : ! ====================================================
155 : ! Generate the communication graph
156 : ! ====================================================
157 2304 : call initMetaGraph(par%rank+1,MetaVertex(1),GridVertex,GridEdge)
158 :
159 2304 : nelemd = LocalElemCount(MetaVertex(1))
160 : if (par%masterproc .and. Debug) then
161 : call PrintMetaVertex(MetaVertex(1))
162 : endif
163 :
164 2304 : if(nelemd <= 0) then
165 0 : call endrun(subname//'Not yet ready to handle nelemd = 0 yet' )
166 : end if
167 2304 : call mpi_allreduce(nelemd, nelemdmax, 1, MPI_INTEGER, MPI_MAX, par%comm, ierr)
168 :
169 : !Allocate elements:
170 2304 : if (nelemd > 0) then
171 23112 : allocate(elem(nelemd))
172 2304 : call allocate_element_desc(elem)
173 : !Allocate Qdp and derived FQ arrays:
174 2304 : if(fv_nphys > 0) then !SE-CSLAM
175 18504 : do ie=1,nelemd
176 48600 : allocate(elem(ie)%state%Qdp(np,np,nlev,thermodynamic_active_species_num,1), stat=ierr)
177 16200 : if( ierr /= 0 ) then
178 0 : call endrun('prim_init1: failed to allocate Qdp array')
179 : end if
180 48600 : allocate(elem(ie)%derived%FQ(np,np,nlev,thermodynamic_active_species_num), stat=ierr)
181 18504 : if( ierr /= 0 ) then
182 0 : call endrun('prim_init1: failed to allocate fq array')
183 : end if
184 : end do
185 : else !Regular SE
186 0 : do ie=1,nelemd
187 0 : allocate(elem(ie)%state%Qdp(np,np,nlev,qsize_d,2), stat=ierr)
188 0 : if( ierr /= 0 ) then
189 0 : call endrun('prim_init1: failed to allocate Qdp array')
190 : end if
191 0 : allocate(elem(ie)%derived%FQ(np,np,nlev,qsize_d), stat=ierr)
192 0 : if( ierr /= 0 ) then
193 0 : call endrun('prim_init1: failed to allocate fq array')
194 : end if
195 : end do
196 : end if
197 : !Allocate remaining derived quantity arrays:
198 18504 : do ie=1,nelemd
199 16200 : allocate(elem(ie)%derived%FDP(np,np,nlev), stat=ierr)
200 16200 : if( ierr /= 0 ) then
201 0 : call endrun('prim_init1: failed to allocate fdp array')
202 : end if
203 16200 : allocate(elem(ie)%derived%divdp(np,np,nlev), stat=ierr)
204 16200 : if( ierr /= 0 ) then
205 0 : call endrun('prim_init1: failed to allocate divdp array')
206 : end if
207 16200 : allocate(elem(ie)%derived%divdp_proj(np,np,nlev), stat=ierr)
208 18504 : if( ierr /= 0 ) then
209 0 : call endrun('prim_init1: failed to allocate divdp_proj array')
210 : end if
211 : end do
212 : end if
213 :
214 2304 : if (fv_nphys > 0) then
215 23112 : allocate(fvm(nelemd))
216 2304 : call allocate_physgrid_vars(fvm,par)
217 : else
218 : ! Even if fvm not needed, still desirable to allocate it as empty
219 : ! so it can be passed as a (size zero) array rather than pointer.
220 0 : allocate(fvm(0))
221 : end if
222 :
223 : ! ====================================================
224 : ! Generate the communication schedule
225 : ! ====================================================
226 :
227 2304 : call genEdgeSched(par, elem, par%rank+1, Schedule(1), MetaVertex(1))
228 :
229 6912 : allocate(global_shared_buf(nelemd, nrepro_vars))
230 70558056 : global_shared_buf = 0.0_r8
231 :
232 2304 : call syncmp(par)
233 :
234 : ! =================================================================
235 : ! Set number of domains (for 'decompose') equal to number of threads
236 : ! for OpenMP across elements, equal to 1 for OpenMP within element
237 : ! =================================================================
238 :
239 : ! =================================================================
240 : ! Initialize shared boundary_exchange and reduction buffers
241 : ! =================================================================
242 2304 : if(par%masterproc) then
243 3 : write(iulog,*) subname, 'init shared boundary_exchange buffers'
244 3 : call shr_sys_flush(iulog)
245 : end if
246 2304 : call InitReductionBuffer(red,3*nlev,max_num_threads)
247 2304 : call InitReductionBuffer(red_sum,5)
248 2304 : call InitReductionBuffer(red_sum_int,1)
249 2304 : call InitReductionBuffer(red_max,1)
250 2304 : call InitReductionBuffer(red_max_int,1)
251 2304 : call InitReductionBuffer(red_min,1)
252 2304 : call initReductionBuffer(red_flops,1)
253 :
254 2304 : gp = gausslobatto(np) ! GLL points
255 :
256 : ! fvm nodes are equally spaced in alpha/beta
257 : ! HOMME with equ-angular gnomonic projection maps alpha/beta space
258 : ! to the reference element via simple scale + translation
259 : ! thus, fvm nodes in reference element [-1,1] are a tensor product of
260 : ! array 'fvm_corners(:)' computed below:
261 2304 : xtmp = nc
262 11520 : do i = 1, nc+1
263 11520 : fvm_corners(i)= 2*(i-1)/xtmp - 1 ! [-1,1] including end points
264 : end do
265 9216 : do i = 1, nc
266 9216 : fvm_points(i)= ( fvm_corners(i)+fvm_corners(i+1) ) /2
267 : end do
268 :
269 2304 : if (topology == "cube") then
270 2304 : if(par%masterproc) then
271 3 : write(iulog,*) subname, "initializing cube elements..."
272 3 : call shr_sys_flush(iulog)
273 : end if
274 2304 : if (MeshUseMeshFile) then
275 0 : call MeshSetCoordinates(elem)
276 : else
277 18504 : do ie = 1, nelemd
278 18504 : call set_corner_coordinates(elem(ie))
279 : end do
280 2304 : call assign_node_numbers_to_elem(elem, GridVertex)
281 : end if
282 18504 : do ie = 1, nelemd
283 18504 : call cube_init_atomic(elem(ie),gp%points)
284 : end do
285 : end if
286 :
287 : ! =================================================================
288 : ! Initialize mass_matrix
289 : ! =================================================================
290 2304 : if(par%masterproc) then
291 3 : write(iulog,*) subname, 'running mass_matrix'
292 3 : call shr_sys_flush(iulog)
293 : end if
294 2304 : call mass_matrix(par, elem)
295 6912 : allocate(aratio(nelemd,1))
296 :
297 2304 : if (topology == "cube") then
298 2304 : area = 0
299 18504 : do ie = 1, nelemd
300 342504 : aratio(ie,1) = sum(elem(ie)%mp(:,:)*elem(ie)%metdet(:,:))
301 : end do
302 2304 : call repro_sum(aratio, area, nelemd, nelemd, 1, commid=par%comm)
303 2304 : area(1) = 4.0_r8*pi/area(1) ! ratio correction
304 2304 : deallocate(aratio)
305 2304 : if (par%masterproc) then
306 3 : write(iulog,'(2a,f20.17)') subname, "re-initializing cube elements: area correction=", area(1)
307 3 : call shr_sys_flush(iulog)
308 : end if
309 :
310 18504 : do ie = 1, nelemd
311 16200 : call cube_init_atomic(elem(ie),gp%points,area(1))
312 18504 : call rotation_init_atomic(elem(ie),rot_type)
313 : end do
314 : end if
315 :
316 2304 : if(par%masterproc) then
317 3 : write(iulog,*) subname, 're-running mass_matrix'
318 3 : call shr_sys_flush(iulog)
319 : end if
320 2304 : call mass_matrix(par, elem)
321 :
322 : ! =================================================================
323 : ! Determine the global degree of freedome for each gridpoint
324 : ! =================================================================
325 2304 : if(par%masterproc) then
326 3 : write(iulog,*) subname, 'running global_dof'
327 3 : call shr_sys_flush(iulog)
328 : end if
329 2304 : call global_dof(par, elem)
330 :
331 : ! =================================================================
332 : ! Create Unique Indices
333 : ! =================================================================
334 :
335 18504 : do ie = 1, nelemd
336 18504 : call CreateUniqueIndex(elem(ie)%GlobalId,elem(ie)%gdofP,elem(ie)%idxP)
337 : end do
338 :
339 2304 : call SetElemOffset(par,elem, GlobalUniqueCols)
340 :
341 18504 : do ie = 1, nelemd
342 18504 : elem(ie)%idxV=>elem(ie)%idxP
343 : end do
344 :
345 : ! initialize flux terms to 0
346 18504 : do ie = 1, nelemd
347 64800000 : elem(ie)%derived%FM=0.0_r8
348 189945000 : elem(ie)%derived%FQ=0.0_r8
349 31654800 : elem(ie)%derived%FT=0.0_r8
350 31654800 : elem(ie)%derived%FDP=0.0_r8
351 :
352 31654800 : elem(ie)%derived%Omega=0
353 94982904 : elem(ie)%state%dp3d=0
354 : end do
355 :
356 : ! ==========================================================
357 : ! This routines initalizes a Restart file. This involves:
358 : ! I) Setting up the MPI datastructures
359 : ! ==========================================================
360 2304 : deallocate(GridEdge)
361 12443904 : do j = 1, nelem
362 12443904 : call deallocate_gridvertex_nbrs(GridVertex(j))
363 : end do
364 2304 : deallocate(GridVertex)
365 :
366 18504 : do j = 1, MetaVertex(1)%nmembers
367 18504 : call deallocate_gridvertex_nbrs(MetaVertex(1)%members(j))
368 : end do
369 2304 : deallocate(MetaVertex)
370 :
371 : ! =====================================
372 : ! Set number of threads...
373 : ! =====================================
374 2304 : if(par%masterproc) then
375 3 : write(iulog,*) subname, "max_num_threads=",max_num_threads
376 3 : call shr_sys_flush(iulog)
377 : end if
378 :
379 2304 : nets = 1
380 2304 : nete = nelemd
381 2304 : call Prim_Advec_Init1(par, elem)
382 2304 : if (fv_nphys > 0) then
383 2304 : call fvm_init1(par,elem)
384 : end if
385 :
386 : ! =======================================================
387 : ! Allocate memory for subcell flux calculations.
388 : ! =======================================================
389 2304 : call allocate_subcell_integration_matrix_cslam(np, nc)
390 2304 : if (fv_nphys > 0) then
391 2304 : call allocate_subcell_integration_matrix_physgrid(np, fv_nphys)
392 : end if
393 :
394 2304 : call TimeLevel_init(tl)
395 :
396 2304 : if (fv_nphys > 0) then
397 2304 : if(par%masterproc) then
398 3 : write(iulog,*) subname, 'initialize basic fvm coordinate variables'
399 3 : call shr_sys_flush(iulog)
400 : end if
401 18504 : do ie = 1, nelemd
402 0 : call compute_basic_coordinate_vars(elem(ie), nc, irecons_tracer, &
403 0 : fvm(ie)%dalpha, fvm(ie)%dbeta, fvm(ie)%vtx_cart(:,:,1:nc,1:nc), &
404 0 : fvm(ie)%center_cart(1:nc,1:nc), fvm(ie)%area_sphere(1:nc,1:nc), &
405 16200 : fvm(ie)%spherecentroid(:,1:nc,1:nc))
406 0 : call compute_basic_coordinate_vars(elem(ie), fv_nphys, irecons_tracer,&
407 0 : fvm(ie)%dalpha_physgrid, fvm(ie)%dbeta_physgrid, &
408 32400 : fvm(ie)%vtx_cart_physgrid (:,:,1:fv_nphys,1:fv_nphys), &
409 32400 : fvm(ie)%center_cart_physgrid(1:fv_nphys,1:fv_nphys), &
410 32400 : fvm(ie)%area_sphere_physgrid(1:fv_nphys,1:fv_nphys), &
411 115704 : fvm(ie)%spherecentroid_physgrid(:,1:fv_nphys,1:fv_nphys))
412 : end do
413 : end if
414 :
415 2304 : if(par%masterproc) then
416 3 : write(iulog,*) subname, 'end of prim_init'
417 3 : call shr_sys_flush(iulog)
418 : end if
419 2304 : end subroutine prim_init1
420 : end module prim_init
|