LCOV - code coverage report
Current view: top level - dynamics/se/dycore - viscosity_mod.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 71 209 34.0 %
Date: 2025-03-13 19:18:33 Functions: 2 14 14.3 %

          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

Generated by: LCOV version 1.14