LCOV - code coverage report
Current view: top level - dynamics/se/dycore - prim_init.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 154 181 85.1 %
Date: 2025-03-13 19:18:33 Functions: 1 1 100.0 %

          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

Generated by: LCOV version 1.14