!!****************************************************************************** !! !! This file is part of the AMUN source code, a program to perform !! Newtonian or relativistic magnetohydrodynamical simulations on uniform or !! adaptive mesh. !! !! Copyright (C) 2017-2024 Grzegorz Kowal !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License as published by !! the Free Software Foundation, either version 3 of the License, or !! (at your option) any later version. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !!***************************************************************************** !! !! module: USER_PROBLEM !! !! This module provides subroutines to setup custom problem. !! !!***************************************************************************** ! module user_problem implicit none integer :: profile = 1 real(kind=8), save :: beta = 2.00d+00 real(kind=8), save :: zeta = 0.00d+00 real(kind=8), save :: dens = 1.00d+00 real(kind=8), save :: bamp = 1.00d+00 real(kind=8), save :: bgui = 0.00d+00 real(kind=8), save :: dlta = 1.00d-02 real(kind=8), save :: pres = 5.00d-01 real(kind=8), save :: pmag = 5.00d-01 real(kind=8), save :: ptot = 1.00d+00 real(kind=8), save :: valf = 1.00d+00 real(kind=8), save :: lund = 1.00d+00 real(kind=8), save :: eta = 0.00d+00 integer(kind=4), save :: runit = 33 logical, save :: resistive = .false. private public :: initialize_user_problem, finalize_user_problem public :: user_statistics !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! contains ! !=============================================================================== ! ! subroutine INITIALIZE_USER_PROBLEM: ! ---------------------------------- ! ! Subroutine initializes user problem. It could read problem parameters which ! are used in all subroutines defining this specific problem. ! ! Arguments: ! ! problem - the problem name ! rcount - the run count for restarted jobs ! verbose - a logical flag turning the information printing; ! status - an integer flag for error return value; ! !=============================================================================== ! subroutine initialize_user_problem(problem, rcount, verbose, status) use boundaries , only : custom_boundary_x, custom_boundary_y use equations , only : adiabatic_index, csnd, csnd2, ipr use helpers , only : print_section, print_parameter, print_message use mesh , only : setup_problem use parameters , only : get_parameter implicit none character(len=64), intent(in) :: problem integer , intent(in) :: rcount logical , intent(in) :: verbose integer , intent(out) :: status character(len=64) :: tmp, append = "off", fname logical :: flag character(len=*), parameter :: & loc = 'USER_PROBLEM::initialize_user_problem()' !------------------------------------------------------------------------------- ! call get_parameter("profile", tmp) select case(tmp) case('bhattacharjee', 'sincos', 'trigonometric') profile = 2 case default profile = 1 end select call get_parameter("dens", dens) call get_parameter("bamp", bamp) call get_parameter("bgui", bgui) call get_parameter("beta", beta) if (beta <= 0.0d+00) then if (verbose) & call print_message(loc, "Plasma-beta must be positive (beta > 0.0)!") status = 1 return end if call get_parameter("zeta", zeta) if (zeta < 0.0d+00 .or. zeta > 1.0d+00) then if (verbose) & call print_message(loc, "Parameter 'zeta' must be between 0.0 and 1.0!") status = 1 return end if if (dens <= 0.0d+00) then if (verbose) & call print_message(loc, "Density must be positive (dens > 0.0)!") status = 1 return end if call get_parameter("resistivity", eta) if (eta < 0.0d+00) then if (verbose) & call print_message(loc, "Resistivity cannot be negative!") status = 1 return else resistive = .true. dlta = sqrt(eta) end if call get_parameter("delta", dlta) if (dlta <= 0.0d+00) then if (verbose) & call print_message(loc, & "The initial thickness must be positive (delta > 0.0)!") status = 1 return end if pmag = 0.5d+00 * (bamp**2 + bgui**2) pres = beta * pmag ptot = pres + pmag if (ipr > 0) then csnd2 = adiabatic_index * pres / dens else csnd2 = pres / dens end if csnd = sqrt(csnd2) valf = bamp / sqrt(dens) lund = valf / max(tiny(eta), eta) ! determine if to append or create another file ! call get_parameter("statistics_append", append) select case(trim(append)) case ("on", "ON", "t", "T", "y", "Y", "true", "TRUE", "yes", "YES") write(fname, "('magnetic-flux.dat')") inquire(file = fname, exist = flag) case default write(fname, "('magnetic-flux_',i2.2,'.dat')") rcount flag = .false. end select ! check if the file exists; if not, create a new one, otherwise move to the end ! if (flag .and. rcount > 1) then #ifdef __INTEL_COMPILER open(newunit = runit, file = fname, form = 'formatted', status = 'old' & , position = 'append', buffered = 'yes') #else /* __INTEL_COMPILER */ open(newunit = runit, file = fname, form = 'formatted', status = 'old' & , position = 'append') #endif /* __INTEL_COMPILER */ write(runit,"('#')") else #ifdef __INTEL_COMPILER open(newunit = runit, file = fname, form = 'formatted' & , status = 'replace', buffered = 'yes') #else /* __INTEL_COMPILER */ open(newunit = runit, file = fname, form = 'formatted' & , status = 'replace') #endif /* __INTEL_COMPILER */ end if ! write the integral file header ! write(runit,'("#",a24,8a25)') 'time', '|Bx| int' , & '|Bx| y-adv', '|Bx| z-adv', & '|Bx| y-shr', '|Bx| z-shr', & '|Bx| y-dif', '|Bx| z-dif', & '|Bx| Psi' write(runit,"('#')") call print_section(verbose, "Parameters (* - set, otherwise calculated)") select case(profile) case(2) call print_parameter(verbose, '(*) flux tubes profile', & 'Bhattacharjee et al. (2009)') case default call print_parameter(verbose, '(*) flux tubes profile', & 'Kowal et al. (2023)') end select call print_parameter(verbose, '(*) beta (plasma-beta)' , beta) call print_parameter(verbose, '(*) zeta' , zeta) call print_parameter(verbose, '(*) dens' , dens) call print_parameter(verbose, '(*) bamp (amplitude)' , bamp) call print_parameter(verbose, '(*) bgui (guide field)' , bgui) call print_parameter(verbose, '(*) delta (thickness)' , dlta) call print_parameter(verbose, '( ) pres (thermal pres.)' , pres) call print_parameter(verbose, '( ) pmag (magnetic pres.)', pmag) call print_parameter(verbose, '( ) csnd (sound speed)' , csnd) call print_parameter(verbose, '( ) Valf (Alfven speed)' , valf) if (resistive) & call print_parameter(verbose, '( ) S (Lundquist number)', lund) setup_problem => setup_user_problem custom_boundary_x => user_boundary_x custom_boundary_y => user_boundary_y status = 0 !------------------------------------------------------------------------------- ! end subroutine initialize_user_problem ! !=============================================================================== ! ! subroutine FINALIZE_USER_PROBLEM: ! -------------------------------- ! ! Subroutine releases memory used by the module. ! ! Arguments: ! ! status - an integer flag for error return value; ! !=============================================================================== ! subroutine finalize_user_problem(status) implicit none integer, intent(out) :: status !------------------------------------------------------------------------------- ! status = 0 !------------------------------------------------------------------------------- ! end subroutine finalize_user_problem ! !=============================================================================== ! ! subroutine SETUP_USER_PROBLEM: ! ----------------------------- ! ! Subroutine sets the initial conditions for the user specific problem. ! ! Arguments: ! ! pdata - pointer to the datablock structure of the currently initialized ! block; ! !=============================================================================== ! subroutine setup_user_problem(pdata) use blocks , only : block_data use constants , only : pi, pi2 use coordinates, only : nn => bcells, xmin, xmax use coordinates, only : ax, ay use equations , only : prim2cons, csnd2 use equations , only : idn, ivx, ivy, ivz, ipr, ibx, iby, ibz, ibp implicit none type(block_data), pointer, intent(inout) :: pdata integer :: i, j, k real(kind=8) :: r1, r2, bx, by, bz real(kind=8), dimension(nn) :: x, y real(kind=8), dimension(nn) :: snx, csx, sny, csy, thy, ch2 real(kind=8), dimension(nn,nn) :: az !------------------------------------------------------------------------------- ! x(:) = pdata%meta%xmin + ax(pdata%meta%level,:) y(:) = pdata%meta%ymin + ay(pdata%meta%level,:) select case(profile) case(2) snx(:) = sin(pi * x(:)) csx(:) = cos(pi * x(:)) sny(:) = sin(pi2 * y(:)) csy(:) = cos(pi2 * y(:)) thy(:) = tanh(y(:) / dlta) ch2(:) = cosh(y(:) / dlta)**2 do j = 1, nn do i = 1, nn bx = bamp * csx(i) * (csy(j) * thy(j) + sny(j) / (pi2 * dlta * ch2(j))) by = bamp * 5.0d-01 * snx(i) * sny(j) * thy(j) bz = sqrt(max(0.0d+00, bgui**2 + zeta * (bamp**2 - bx**2 - by**2))) pdata%q(ibx,i,j,:) = bx pdata%q(iby,i,j,:) = by pdata%q(ibz,i,j,:) = bz end do end do pdata%q(ibp,:,:,:) = 0.0d+00 case default do j = 1, nn do i = 1, nn r1 = 5.0d-01 - sqrt(x(i)**2 + ((2.0d+00 * y(j) - 5.0d-01))**2) r2 = 5.0d-01 - sqrt(x(i)**2 + ((2.0d+00 * y(j) + 5.0d-01))**2) az(i,j) = 2.5d-01 * (r1 * (tanh(r1 / dlta) + 1.0d+00) & + r2 * (tanh(r2 / dlta) + 1.0d+00)) end do end do do j = 2, nn - 1 do i = 2, nn - 1 bx = (az(i,j+1) - az(i,j-1)) / (y(j+1) - y(j-1)) by = (az(i-1,j) - az(i+1,j)) / (x(i+1) - x(i-1)) bz = sqrt(max(0.0d+00, bgui**2 + zeta * (bamp**2 - bx**2 - by**2))) pdata%q(ibx,i,j,:) = bx pdata%q(iby,i,j,:) = by pdata%q(ibz,i,j,:) = bz end do end do pdata%q(ibp,:,:,:) = 0.0d+00 end select if (ipr > 0) then pdata%q(idn,:,:,:) = dens pdata%q(ipr,:,:,:) = ptot - 5.0d-01 * sum(pdata%q(ibx:ibz,:,:,:)**2,1) else pdata%q(idn,:,:,:) = (ptot - 5.0d-01 * sum(pdata%q(ibx:ibz,:,:,:)**2,1)) & / csnd2 end if pdata%q(ivx,:,:,:) = 0.0d+00 pdata%q(ivy,:,:,:) = 0.0d+00 pdata%q(ivz,:,:,:) = 0.0d+00 #if NDIMS == 3 do k = 1, nn #else /* NDIMS == 3 */ do k = 1, 1 #endif /* NDIMS == 3 */ do j = 1, nn call prim2cons(pdata%q(:,:,j,k), pdata%u(:,:,j,k), .true.) end do end do !------------------------------------------------------------------------------- ! end subroutine setup_user_problem ! !=============================================================================== ! ! subroutine UPDATE_USER_SOURCES: ! ------------------------------ ! ! Subroutine adds the user defined source terms. ! ! Arguments: ! ! t, dt - the time and time increment; ! pdata - the pointer to a data block; ! !=============================================================================== ! subroutine update_user_sources(t, dt, pdata) use blocks, only : block_data implicit none real(kind=8) , intent(in) :: t, dt type(block_data), pointer, intent(inout) :: pdata !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- ! end subroutine update_user_sources ! !=============================================================================== ! ! subroutine UPDATE_USER_SHAPES: ! ----------------------------- ! ! Subroutine defines the regions updated by user. ! ! Arguments: ! ! pdata - pointer to the data block structure of the currently initialized ! block; ! time - time at the moment of update; ! dt - time step since the last update; ! !=============================================================================== ! subroutine update_user_shapes(pdata, time, dt) use blocks, only : block_data implicit none type(block_data), pointer, intent(inout) :: pdata real(kind=8) , intent(in) :: time, dt !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- ! end subroutine update_user_shapes ! !=============================================================================== ! ! subroutine USER_BOUNDARY_X: ! -------------------------- ! ! Subroutine updates ghost zones within the specific region along ! the X direction. ! ! Arguments: ! ! is - the block side along the X direction for the ghost zone update; ! jl, ju - the cell index limits for the Y direction; ! kl, ku - the cell index limits for the Z direction; ! t, dt - time and time increment; ! x, y, z - the block coordinates; ! qn - the array of variables to update; ! !=============================================================================== ! subroutine user_boundary_x(is, jl, ju, kl, ku, t, dt, x, y, z, qn) use coordinates, only : nn => bcells, nb, ne, nbl, neu use equations , only : ivx, ibx implicit none integer , intent(in) :: is, jl, ju, kl, ku real(kind=8) , intent(in) :: t, dt real(kind=8), dimension(:) , intent(in) :: x, y, z real(kind=8), dimension(:,:,:,:), intent(inout) :: qn integer :: i, j, ir !------------------------------------------------------------------------------- ! if (is == 1) then do i = nbl, 1, -1 ir = nb + (nbl - i) do j = jl, ju qn( : ,i,j,:) = qn( : ,ir,j,:) qn(ivx,i,j,:) = - qn(ivx,ir,j,:) qn(ibx,i,j,:) = - qn(ibx,ir,j,:) end do end do else ! is == 1 do i = neu, nn ir = ne - (i - neu) do j = jl, ju qn( : ,i,j,:) = qn( : ,ir,j,:) qn(ivx,i,j,:) = - qn(ivx,ir,j,:) qn(ibx,i,j,:) = - qn(ibx,ir,j,:) end do end do end if !------------------------------------------------------------------------------- ! end subroutine user_boundary_x ! !=============================================================================== ! ! subroutine USER_BOUNDARY_Y: ! -------------------------- ! ! Subroutine updates ghost zones within the specific region along ! the Y direction. ! ! Arguments: ! ! js - the block side along the Y direction for the ghost zone update; ! il, iu - the cell index limits for the X direction; ! kl, ku - the cell index limits for the Z direction; ! t, dt - time and time increment; ! x, y, z - the block coordinates; ! qn - the array of variables to update; ! !=============================================================================== ! subroutine user_boundary_y(js, il, iu, kl, ku, t, dt, x, y, z, qn) use coordinates, only : nn => bcells, nb, ne, nbl, neu use equations , only : ivy, iby implicit none integer , intent(in) :: js, il, iu, kl, ku real(kind=8) , intent(in) :: t, dt real(kind=8), dimension(:) , intent(in) :: x, y, z real(kind=8), dimension(:,:,:,:), intent(inout) :: qn integer :: i, j, jr !------------------------------------------------------------------------------- ! if (js == 1) then do j = nbl, 1, -1 jr = nb + (nbl - j) do i = il, iu qn( : ,i,j,:) = qn( : ,i,jr,:) qn(ivy,i,j,:) = - qn(ivy,i,jr,:) qn(iby,i,j,:) = - qn(iby,i,jr,:) end do end do else ! js == 1 do j = neu, nn jr = ne - (j - neu) do i = il, iu qn( : ,i,j,:) = qn( : ,i,jr,:) qn(ivy,i,j,:) = - qn(ivy,i,jr,:) qn(iby,i,j,:) = - qn(iby,i,jr,:) end do end do end if !------------------------------------------------------------------------------- ! end subroutine user_boundary_y ! !=============================================================================== ! ! subroutine USER_BOUNDARY_Z: ! -------------------------- ! ! Subroutine updates ghost zones within the specific region along ! the Z direction. ! ! Arguments: ! ! ks - the block side along the Z direction for the ghost zone update; ! il, iu - the cell index limits for the X direction; ! jl, ju - the cell index limits for the Y direction; ! t, dt - time and time increment; ! x, y, z - the block coordinates; ! qn - the array of variables to update; ! !=============================================================================== ! subroutine user_boundary_z(ks, il, iu, jl, ju, t, dt, x, y, z, qn) implicit none integer , intent(in) :: ks, il, iu,jl, ju real(kind=8) , intent(in) :: t, dt real(kind=8), dimension(:) , intent(in) :: x, y, z real(kind=8), dimension(:,:,:,:), intent(inout) :: qn !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- ! end subroutine user_boundary_z ! !=============================================================================== ! ! subroutine USER_STATISTICS: ! ------------------------------- ! ! Subroutine can be use to store user defined time statistics. The file to ! store these statistics should be properly created in subroutine ! initialize_user_problem() and closed in finalize_user_problem(). ! ! Arguments: ! ! time - the current simulation time; ! !=============================================================================== ! subroutine user_statistics(time) use blocks , only : block_meta, block_data, list_data use coordinates, only : nc => ncells, nn => bcells, nb, ne, nbm, nep #if NDIMS == 3 use coordinates, only : periodic, ymin, ymax, zmin, zmax #else /* NDIMS == 3 */ use coordinates, only : periodic, ymin, ymax #endif /* NDIMS == 3 */ use coordinates, only : ax, adx, ady, adz #if NDIMS == 3 use equations , only : ivx, ivy, ivz, ibx, iby, ibz, ibp #else /* NDIMS == 3 */ use equations , only : ivx, ivy, ibx, iby, ibz, ibp #endif /* NDIMS == 3 */ use helpers , only : print_message, flush_and_sync #ifdef MPI use mpitools , only : reduce_sum #endif /* MPI */ use operators , only : curl, derivative_1st use workspace , only : resize_workspace, work, work_in_use implicit none real(kind=8), intent(in) :: time logical, save :: first = .true. type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata integer, save :: nt, i !$ integer :: omp_get_thread_num integer :: nl, nu, status real(kind=8) :: dyz real(kind=8), dimension(3) :: dh real(kind=8), dimension(16) :: rterms real(kind=8), dimension(nn) :: x real(kind=8), dimension(:,:,:,:), pointer, save :: cur real(kind=8), dimension(:,:) , pointer, save :: vv, bb, jj !$omp threadprivate(first, nt, i, cur, vv, bb, jj) character(len=*), parameter :: loc = 'USER_PROBLEM:user_time_statistics()' !------------------------------------------------------------------------------- ! nt = 0 !$ nt = omp_get_thread_num() if (first) then if (resistive) then nu = 3 * nn**NDIMS + 9 * nc**(NDIMS - 2) else nu = 3 * nn**NDIMS + 6 * nc**(NDIMS - 2) end if call resize_workspace(nu, status) if (status /= 0) then call print_message(loc, "Could not resize the workspace!") go to 100 end if nl = 1 nu = nl - 1 + 3 * nn**NDIMS #if NDIMS == 3 cur(1:3,1:nn,1:nn,1:nn) => work(nl:nu,nt) #else /* NDIMS == 3 */ cur(1:3,1:nn,1:nn,1: 1) => work(nl:nu,nt) #endif /* NDIMS == 3 */ nl = nu + 1 nu = nl - 1 + 3 * nc**(NDIMS - 2) #if NDIMS == 3 vv(1:3,1:nc) => work(nl:nu,nt) #else /* NDIMS == 3 */ vv(1:3,1: 1) => work(nl:nu,nt) #endif /* NDIMS == 3 */ nl = nu + 1 nu = nl - 1 + 3 * nc**(NDIMS - 2) #if NDIMS == 3 bb(1:3,1:nc) => work(nl:nu,nt) #else /* NDIMS == 3 */ bb(1:3,1: 1) => work(nl:nu,nt) #endif /* NDIMS == 3 */ if (resistive) then nl = nu + 1 nu = nl - 1 + 3 * nc**(NDIMS - 2) #if NDIMS == 3 jj(1:3,1:nc) => work(nl:nu,nt) #else /* NDIMS == 3 */ jj(1:3,1: 1) => work(nl:nu,nt) #endif /* NDIMS == 3 */ end if first = .false. end if rterms(:) = 0.0d+00 if (work_in_use(nt)) & call print_message(loc, & "Workspace is being used right now! Corruptions can occur!") work_in_use(nt) = .true. pdata => list_data do while(associated(pdata)) pmeta => pdata%meta if (pmeta%xmin <= 0.0d+00 .and. pmeta%xmax >= 0.0d+00) then dh(1) = adx(pmeta%level) dh(2) = ady(pmeta%level) dh(3) = adz(pmeta%level) x(:) = pmeta%xmin + ax(pmeta%level,:) i = nb do while(abs(x(i)) > dh(1) .and. i <= ne) i = i + 1 end do if (nb < i .and. i <= ne) then dyz = ady(pmeta%level) * adz(pmeta%level) ! the integral of |Bx| ! rterms(1) = rterms(1) & #if NDIMS == 3 + sum(abs(pdata%u(ibx,i,nb:ne,nb:ne))) * dyz #else /* NDIMS == 3 */ + sum(abs(pdata%u(ibx,i,nb:ne, : ))) * dyz #endif /* NDIMS == 3 */ ! calculate current density (J = ∇xB) ! if (resistive) & call curl(dh(:), pdata%q(ibx:ibz,:,:,:), cur(1:3,:,:,:)) if (.not. periodic(2)) then if (pmeta%ymin - dh(2) < ymin) then #if NDIMS == 3 vv(1,:) = 5.0d-01 * sum(pdata%q(ivx,i,nbm:nb,nb:ne), 1) vv(2,:) = 5.0d-01 * sum(pdata%q(ivy,i,nbm:nb,nb:ne), 1) bb(1,:) = 5.0d-01 * sum(pdata%q(ibx,i,nbm:nb,nb:ne), 1) bb(2,:) = 5.0d-01 * sum(pdata%q(iby,i,nbm:nb,nb:ne), 1) #else /* NDIMS == 3 */ vv(1,:) = 5.0d-01 * sum(pdata%q(ivx,i,nbm:nb, : ), 1) vv(2,:) = 5.0d-01 * sum(pdata%q(ivy,i,nbm:nb, : ), 1) bb(1,:) = 5.0d-01 * sum(pdata%q(ibx,i,nbm:nb, : ), 1) bb(2,:) = 5.0d-01 * sum(pdata%q(iby,i,nbm:nb, : ), 1) #endif /* NDIMS == 3 */ ! advection of Bx across the Y-boundary ! rterms(2) = rterms(2) & + sum(sign(bb(1,:) * vv(2,:), bb(1,:))) * dh(3) ! shear of By along the Y-boundary ! rterms(4) = rterms(4) & - sum(sign(bb(2,:) * vv(1,:), bb(1,:))) * dh(3) if (resistive) then #if NDIMS == 3 jj(3,:) = 5.0d-01 * sum(cur(3,i,nbm:nb,nb:ne), 1) #else /* NDIMS == 3 */ jj(3,:) = 5.0d-01 * sum(cur(3,i,nbm:nb, : ), 1) #endif /* NDIMS == 3 */ ! diffusion of Bx at the Y-boundary ! rterms(6) = rterms(6) & + sum(sign(jj(3,:), bb(1,:))) * dh(3) end if ! resistivity end if if (pmeta%ymax + dh(2) > ymax) then #if NDIMS == 3 vv(1,:) = 5.0d-01 * sum(pdata%q(ivx,i,ne:nep,nb:ne), 1) vv(2,:) = 5.0d-01 * sum(pdata%q(ivy,i,ne:nep,nb:ne), 1) bb(1,:) = 5.0d-01 * sum(pdata%q(ibx,i,ne:nep,nb:ne), 1) bb(2,:) = 5.0d-01 * sum(pdata%q(iby,i,ne:nep,nb:ne), 1) #else /* NDIMS == 3 */ vv(1,:) = 5.0d-01 * sum(pdata%q(ivx,i,ne:nep, : ), 1) vv(2,:) = 5.0d-01 * sum(pdata%q(ivy,i,ne:nep, : ), 1) bb(1,:) = 5.0d-01 * sum(pdata%q(ibx,i,ne:nep, : ), 1) bb(2,:) = 5.0d-01 * sum(pdata%q(iby,i,ne:nep, : ), 1) #endif /* NDIMS == 3 */ ! advection of Bx across the Y-boundary ! rterms(2) = rterms(2) & - sum(sign(bb(1,:) * vv(2,:), bb(1,:))) * dh(3) ! shear of By along the Y-boundary ! rterms(4) = rterms(4) & + sum(sign(bb(2,:) * vv(1,:), bb(1,:))) * dh(3) if (resistive) then #if NDIMS == 3 jj(3,:) = 5.0d-01 * sum(cur(3,i,ne:nep,nb:ne), 1) #else /* NDIMS == 3 */ jj(3,:) = 5.0d-01 * sum(cur(3,i,ne:nep, : ), 1) #endif /* NDIMS == 3 */ ! diffusion of Bx at the Y-boundary ! rterms(6) = rterms(6) & - sum(sign(jj(3,:), bb(1,:))) * dh(3) end if ! resistivity end if end if ! non-periodic along Y #if NDIMS == 3 if (.not. periodic(3)) then if (pmeta%zmin - dh(3) < zmin) then vv(1,:) = 5.0d-01 * sum(pdata%q(ivx,i,nb:ne,nbm:nb), 1) vv(3,:) = 5.0d-01 * sum(pdata%q(ivz,i,nb:ne,nbm:nb), 1) bb(1,:) = 5.0d-01 * sum(pdata%q(ibx,i,nb:ne,nbm:nb), 1) bb(3,:) = 5.0d-01 * sum(pdata%q(ibz,i,nb:ne,nbm:nb), 1) ! advection of Bx across the Z-boundary ! rterms(3) = rterms(3) & + sum(sign(bb(1,:) * vv(3,:), bb(1,:))) * dh(2) ! shear of Bz along the Z-boundary ! rterms(5) = rterms(5) & - sum(sign(bb(3,:) * vv(1,:), bb(1,:))) * dh(2) if (resistive) then jj(2,:) = 5.0d-01 * sum(cur(2,i,nb:ne,nbm:nb), 1) ! diffusion of Bx at the Z-boundary ! rterms(7) = rterms(7) & + sum(sign(jj(2,:), bb(1,:))) * dh(2) end if ! resistivity end if if (pmeta%zmax + dh(3) > zmax) then vv(1,:) = 5.0d-01 * sum(pdata%q(ivx,i,nb:ne,ne:nep), 1) vv(3,:) = 5.0d-01 * sum(pdata%q(ivz,i,nb:ne,ne:nep), 1) bb(1,:) = 5.0d-01 * sum(pdata%q(ibx,i,nb:ne,ne:nep), 1) bb(3,:) = 5.0d-01 * sum(pdata%q(ibz,i,nb:ne,ne:nep), 1) ! advection of Bx across the Z-boundary ! rterms(3) = rterms(3) & - sum(sign(bb(1,:) * vv(3,:), bb(1,:))) * dh(2) ! shear of Bz along the Z-boundary ! rterms(5) = rterms(5) & + sum(sign(bb(3,:) * vv(1,:), bb(1,:))) * dh(2) if (resistive) then jj(2,:) = 5.0d-01 * sum(cur(2,1,nb:ne,ne:nep), 1) ! diffusion of Bx at the Z-boundary ! rterms(7) = rterms(7) & - sum(sign(jj(2,:), bb(1,:))) * dh(2) end if ! resistivity end if end if ! non-periodic along Z #endif /* NDIMS == 3 */ ! calculate X-derivative of ψ ! call derivative_1st(1, dh(1), pdata%q(ibp,:,:,:), cur(1,:,:,:)) rterms(8) = rterms(8) & #if NDIMS == 3 - sum(sign(cur(1,i,nb:ne,nb:ne), & pdata%q(ibx,i,nb:ne,nb:ne))) * dyz #else /* NDIMS == 3 */ - sum(sign(cur(1,i,nb:ne, : ), & pdata%q(ibx,i,nb:ne, : ))) * dyz #endif /* NDIMS == 3 */ end if end if pdata => pdata%next end do work_in_use(nt) = .false. #ifdef MPI call reduce_sum(rterms(:)) #endif /* MPI */ rterms(6) = eta * rterms(6) rterms(7) = eta * rterms(7) write(runit,"(9es25.15e3)") time, rterms(1:8) call flush_and_sync(runit) 100 continue !------------------------------------------------------------------------------- ! end subroutine user_statistics !=============================================================================== ! end module user_problem