!!****************************************************************************** !! !! module: problem - handling the initial problem definition !! !! Copyright (C) 2008-2010 Grzegorz Kowal !! !!****************************************************************************** !! !! This file is part of Godunov-AMR. !! !! Godunov-AMR 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. !! !! Godunov-AMR 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 problem implicit none contains ! !=============================================================================== ! ! init_domain: subroutine initializes the domain for a given problem ! !=============================================================================== ! subroutine init_domain use config, only : problem ! !------------------------------------------------------------------------------- ! select case(trim(problem)) #if NDIMS == 2 case("blast") call domain_blast() #endif /* NDIMS == 2 */ case default call domain_default() end select !------------------------------------------------------------------------------- ! end subroutine init_domain ! !=============================================================================== ! ! init_problem: subroutine initializes the variables according to ! the studied problem ! !=============================================================================== ! subroutine init_problem(pblock) use blocks, only : block_data use config, only : problem ! input arguments ! type(block_data), pointer, intent(inout) :: pblock ! local arguments ! type(block_data), pointer :: pb ! !------------------------------------------------------------------------------- ! pb => pblock select case(trim(problem)) case("blast") call init_blast(pb) case("implosion") call init_implosion(pb) case("binaries") call init_binaries(pb) case("reconnection") call init_reconnection(pb) end select nullify(pb) !------------------------------------------------------------------------------- ! end subroutine init_problem #ifdef SHAPE ! !=============================================================================== ! ! shapes: subroutine resets the update for a give shape ! !=============================================================================== ! subroutine update_shapes(pblock, du) use blocks, only : block_data use config, only : problem ! input arguments ! type(block_data), pointer, intent(inout) :: pblock real, dimension(:,:,:,:) , intent(inout) :: du ! local arguments ! type(block_data), pointer :: pb ! !------------------------------------------------------------------------------- ! pb => pblock select case(trim(problem)) case("binaries") call shape_binaries(pb, du) case default end select nullify(pb) !------------------------------------------------------------------------------- ! end subroutine update_shapes #endif /* SHAPE */ ! !=============================================================================== ! ! domain_default: subroutine initializes the default domain of 2x2 blocks in ! 'N' configuration ! !=============================================================================== ! subroutine domain_default use blocks, only : block_meta, block_data, append_metablock & , append_datablock, associate_blocks, metablock_setleaf & , metablock_setconfig, metablock_setlevel & , metablock_set_coord, metablock_setbounds & , nsides, nfaces use config, only : xlbndry, xubndry, ylbndry, yubndry, zlbndry, zubndry & , xmin, xmax, ymin, ymax, zmin, zmax implicit none ! local variables ! integer :: i, j ! local pointers ! type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata ! !------------------------------------------------------------------------------- ! ! create root meta blocks ! call append_metablock(pmeta) ! mark block as a leaf ! call metablock_setleaf(pmeta) ! set block config flag ! call metablock_setconfig(pmeta, 12) ! set block level ! call metablock_setlevel(pmeta, 1) ! set block coordinates ! call metablock_set_coord(pmeta, 0, 0, 0) ! set block bounds ! call metablock_setbounds(pmeta, xmin, xmax, ymin, ymax, zmin, zmax) ! if periodic boundary conditions set all neighbors to itself ! if (xlbndry .eq. 'periodic' .and. xubndry .eq. 'periodic') then do j = 1, nfaces do i = 1, nsides pmeta%neigh(1,i,j)%ptr => pmeta end do end do end if if (ylbndry .eq. 'periodic' .and. yubndry .eq. 'periodic') then do j = 1, nfaces do i = 1, nsides pmeta%neigh(2,i,j)%ptr => pmeta end do end do end if #if NDIMS == 3 if (zlbndry .eq. 'periodic' .and. zubndry .eq. 'periodic') then do j = 1, nfaces do i = 1, nsides pmeta%neigh(3,i,j)%ptr => pmeta end do end do end if #endif /* NDIMS == 3 */ ! create root data block ! call append_datablock(pdata) ! associate root blocks ! call associate_blocks(pmeta, pdata) ! !------------------------------------------------------------------------------- ! end subroutine domain_default ! !=============================================================================== ! ! domain_default: subroutine initializes the default domain of 2x2 blocks in ! 'N' configuration ! !=============================================================================== ! subroutine domain_blast use blocks, only : block_meta, block_data, pointer_meta, append_metablock & , append_datablock, associate_blocks, metablock_setleaf & , metablock_setconfig, metablock_setlevel & , metablock_setbounds, metablock_set_coord & , nsides, nfaces, res use config, only : xlbndry, xubndry, ylbndry, yubndry, zlbndry, zubndry & , xmin, xmax, ymin, ymax, zmin, zmax, rdims, maxlev, ncells implicit none ! local variables ! integer :: i, j, ih, jl, ju real :: xm, yl, yu ! local pointers ! type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata ! local pointer array ! type(pointer_meta) :: block_array(2,3) ! !------------------------------------------------------------------------------- ! !! TO DO: !! !! create a general way to initiate NxM blocks at level 1 !! !! ! create root meta blocks ! call append_metablock(block_array(1,1)%ptr) call append_metablock(block_array(2,1)%ptr) call append_metablock(block_array(2,2)%ptr) call append_metablock(block_array(1,2)%ptr) call append_metablock(block_array(1,3)%ptr) call append_metablock(block_array(2,3)%ptr) ! mark block as a leaf ! call metablock_setleaf(block_array(1,1)%ptr) call metablock_setleaf(block_array(2,1)%ptr) call metablock_setleaf(block_array(2,2)%ptr) call metablock_setleaf(block_array(1,2)%ptr) call metablock_setleaf(block_array(1,3)%ptr) call metablock_setleaf(block_array(2,3)%ptr) ! set block config flag ! call metablock_setconfig(block_array(1,1)%ptr, 12) call metablock_setconfig(block_array(2,1)%ptr, 13) call metablock_setconfig(block_array(2,2)%ptr, 13) call metablock_setconfig(block_array(1,2)%ptr, 43) call metablock_setconfig(block_array(1,3)%ptr, 12) call metablock_setconfig(block_array(2,3)%ptr, 12) ! set block level ! call metablock_setlevel(block_array(1,1)%ptr, 1) call metablock_setlevel(block_array(2,1)%ptr, 1) call metablock_setlevel(block_array(2,2)%ptr, 1) call metablock_setlevel(block_array(1,2)%ptr, 1) call metablock_setlevel(block_array(1,3)%ptr, 1) call metablock_setlevel(block_array(2,3)%ptr, 1) ! set boundary conditions ! block_array(1,1)%ptr%neigh(1,1,1)%ptr => block_array(2,1)%ptr block_array(1,1)%ptr%neigh(1,1,2)%ptr => block_array(2,1)%ptr block_array(1,1)%ptr%neigh(1,2,1)%ptr => block_array(2,1)%ptr block_array(1,1)%ptr%neigh(1,2,2)%ptr => block_array(2,1)%ptr block_array(1,1)%ptr%neigh(2,1,1)%ptr => block_array(1,3)%ptr block_array(1,1)%ptr%neigh(2,1,2)%ptr => block_array(1,3)%ptr block_array(1,1)%ptr%neigh(2,2,1)%ptr => block_array(1,2)%ptr block_array(1,1)%ptr%neigh(2,2,2)%ptr => block_array(1,2)%ptr block_array(1,2)%ptr%neigh(1,1,1)%ptr => block_array(2,2)%ptr block_array(1,2)%ptr%neigh(1,1,2)%ptr => block_array(2,2)%ptr block_array(1,2)%ptr%neigh(1,2,1)%ptr => block_array(2,2)%ptr block_array(1,2)%ptr%neigh(1,2,2)%ptr => block_array(2,2)%ptr block_array(1,2)%ptr%neigh(2,1,1)%ptr => block_array(1,1)%ptr block_array(1,2)%ptr%neigh(2,1,2)%ptr => block_array(1,1)%ptr block_array(1,2)%ptr%neigh(2,2,1)%ptr => block_array(1,3)%ptr block_array(1,2)%ptr%neigh(2,2,2)%ptr => block_array(1,3)%ptr block_array(1,3)%ptr%neigh(1,1,1)%ptr => block_array(2,3)%ptr block_array(1,3)%ptr%neigh(1,1,2)%ptr => block_array(2,3)%ptr block_array(1,3)%ptr%neigh(1,2,1)%ptr => block_array(2,3)%ptr block_array(1,3)%ptr%neigh(1,2,2)%ptr => block_array(2,3)%ptr block_array(1,3)%ptr%neigh(2,1,1)%ptr => block_array(1,2)%ptr block_array(1,3)%ptr%neigh(2,1,2)%ptr => block_array(1,2)%ptr block_array(1,3)%ptr%neigh(2,2,1)%ptr => block_array(1,1)%ptr block_array(1,3)%ptr%neigh(2,2,2)%ptr => block_array(1,1)%ptr block_array(2,1)%ptr%neigh(1,1,1)%ptr => block_array(1,1)%ptr block_array(2,1)%ptr%neigh(1,1,2)%ptr => block_array(1,1)%ptr block_array(2,1)%ptr%neigh(1,2,1)%ptr => block_array(1,1)%ptr block_array(2,1)%ptr%neigh(1,2,2)%ptr => block_array(1,1)%ptr block_array(2,1)%ptr%neigh(2,1,1)%ptr => block_array(2,3)%ptr block_array(2,1)%ptr%neigh(2,1,2)%ptr => block_array(2,3)%ptr block_array(2,1)%ptr%neigh(2,2,1)%ptr => block_array(2,2)%ptr block_array(2,1)%ptr%neigh(2,2,2)%ptr => block_array(2,2)%ptr block_array(2,2)%ptr%neigh(1,1,1)%ptr => block_array(1,2)%ptr block_array(2,2)%ptr%neigh(1,1,2)%ptr => block_array(1,2)%ptr block_array(2,2)%ptr%neigh(1,2,1)%ptr => block_array(1,2)%ptr block_array(2,2)%ptr%neigh(1,2,2)%ptr => block_array(1,2)%ptr block_array(2,2)%ptr%neigh(2,1,1)%ptr => block_array(2,1)%ptr block_array(2,2)%ptr%neigh(2,1,2)%ptr => block_array(2,1)%ptr block_array(2,2)%ptr%neigh(2,2,1)%ptr => block_array(2,3)%ptr block_array(2,2)%ptr%neigh(2,2,2)%ptr => block_array(2,3)%ptr block_array(2,3)%ptr%neigh(1,1,1)%ptr => block_array(1,3)%ptr block_array(2,3)%ptr%neigh(1,1,2)%ptr => block_array(1,3)%ptr block_array(2,3)%ptr%neigh(1,2,1)%ptr => block_array(1,3)%ptr block_array(2,3)%ptr%neigh(1,2,2)%ptr => block_array(1,3)%ptr block_array(2,3)%ptr%neigh(2,1,1)%ptr => block_array(2,2)%ptr block_array(2,3)%ptr%neigh(2,1,2)%ptr => block_array(2,2)%ptr block_array(2,3)%ptr%neigh(2,2,1)%ptr => block_array(2,1)%ptr block_array(2,3)%ptr%neigh(2,2,2)%ptr => block_array(2,1)%ptr ! prepare the coordinates ! ih = res(1) jl = res(1) ju = res(1) + jl ! set the coordinates ! call metablock_set_coord(block_array(1,1)%ptr, 0, 0, 0) call metablock_set_coord(block_array(2,1)%ptr, ih, 0, 0) call metablock_set_coord(block_array(1,2)%ptr, 0, jl, 0) call metablock_set_coord(block_array(2,2)%ptr, ih, jl, 0) call metablock_set_coord(block_array(1,3)%ptr, 0, ju, 0) call metablock_set_coord(block_array(2,3)%ptr, ih, ju, 0) ! calculate bounds ! xm = 0.5 * (xmin + xmax) yl = (ymax - ymin) / 3.0 + ymin yu = (ymax - ymin) / 3.0 + yl ! set block bounds ! call metablock_setbounds(block_array(1,1)%ptr, xmin, xm , ymin, yl , zmin, zmax) call metablock_setbounds(block_array(2,1)%ptr, xm , xmax, ymin, yl , zmin, zmax) call metablock_setbounds(block_array(2,2)%ptr, xm , xmax, yl , yu , zmin, zmax) call metablock_setbounds(block_array(1,2)%ptr, xmin, xm , yl , yu , zmin, zmax) call metablock_setbounds(block_array(1,3)%ptr, xmin, xm , yu , ymax, zmin, zmax) call metablock_setbounds(block_array(2,3)%ptr, xm , xmax, yu , ymax, zmin, zmax) ! create root data block ! call append_datablock(pdata) call associate_blocks(block_array(1,1)%ptr, pdata) call append_datablock(pdata) call associate_blocks(block_array(2,1)%ptr, pdata) call append_datablock(pdata) call associate_blocks(block_array(2,2)%ptr, pdata) call append_datablock(pdata) call associate_blocks(block_array(1,2)%ptr, pdata) call append_datablock(pdata) call associate_blocks(block_array(1,3)%ptr, pdata) call append_datablock(pdata) call associate_blocks(block_array(2,3)%ptr, pdata) ! set the block dimensions for the lowest level ! rdims(1) = 2 rdims(2) = 3 ! !------------------------------------------------------------------------------- ! end subroutine domain_blast ! !=============================================================================== ! ! init_blast: subroutine initializes the variables for the blast problem ! !=============================================================================== ! subroutine init_blast(pblock) use blocks , only : block_data use config , only : in, jn, kn, im, jm, km, ng & , gamma, csnd2, rcut, dens, dnrat use scheme , only : prim2cons use variables, only : nvr, nqt, idn, ivx, ivy, ivz #ifdef ADI use variables, only : ipr #endif /* ADI */ #ifdef MHD use variables, only : ibx, iby, ibz #ifdef FLUXCT use variables, only : icx, icy, icz #endif /* FLUXCT */ #ifdef GLM use variables, only : iph #endif /* GLM */ #endif /* MHD */ ! input arguments ! type(block_data), pointer, intent(inout) :: pblock ! local variables ! integer(kind=4), dimension(3) :: dm integer :: i, j, k real :: r, dx, dy, dz, pr ! local arrays ! real, dimension(im) :: x real, dimension(jm) :: y real, dimension(km) :: z real, dimension(nvr,im) :: q, u ! !------------------------------------------------------------------------------- ! ! calculate parameters ! #ifdef ADI pr = dens * csnd2 / gamma #endif /* ADI */ ! calculate cell sizes ! dx = (pblock%meta%xmax - pblock%meta%xmin) / in dy = (pblock%meta%ymax - pblock%meta%ymin) / jn #if NDIMS == 3 dz = (pblock%meta%zmax - pblock%meta%zmin) / kn #else /* NDIMS == 3 */ dz = 1.0 #endif /* NDIMS == 3 */ ! generate coordinates ! x(:) = ((/(i, i = 1, im)/) - ng - 0.5) * dx + pblock%meta%xmin y(:) = ((/(j, j = 1, jm)/) - ng - 0.5) * dy + pblock%meta%ymin #if NDIMS == 3 z(:) = ((/(k, k = 1, km)/) - ng - 0.5) * dz + pblock%meta%zmin #else /* NDIMS == 3 */ z(1) = 0.0 #endif /* NDIMS == 3 */ ! set variables ! q(idn,:) = dens q(ivx,:) = 0.0d0 q(ivy,:) = 0.0d0 q(ivz,:) = 0.0d0 #ifdef MHD q(ibx,:) = 0.70710678118654752440 q(iby,:) = 0.70710678118654752440 q(ibz,:) = 0.0d0 #ifdef FLUXCT q(icx,:) = 0.70710678118654752440 q(icy,:) = 0.70710678118654752440 q(icz,:) = 0.0d0 #endif /* FLUXCT */ #ifdef GLM q(iph,:) = 0.0d0 #endif /* GLM */ #endif /* MHD */ ! set initial pressure ! do k = 1, km do j = 1, jm ! fill out the pressure profile ! do i = 1, im r = sqrt(x(i)**2 + y(j)**2 + z(k)**2) #ifdef ISO if (r .lt. rcut) then q(idn,i) = dens * dnrat else q(idn,i) = dens end if #endif /* ISO */ #ifdef ADI if (r .lt. rcut) then q(ipr,i) = pr * dnrat else q(ipr,i) = pr end if #endif /* ADI */ end do ! convert primitive variables to conserved ! call prim2cons(im, q, u) ! copy conservative variables to the current block ! pblock%u(1:nqt,1:im,j,k) = u(1:nqt,1:im) end do end do ! !------------------------------------------------------------------------------- ! end subroutine init_blast ! !=============================================================================== ! ! init_implosion: subroutine initializes variables for the implosion problem ! !=============================================================================== ! subroutine init_implosion(pblock) use blocks , only : block_data use config , only : in, jn, kn, im, jm, km, ng, dens, pres, rmid, gammam1i use variables, only : idn, imx, imy, imz #ifdef ADI use variables, only : ien #endif /* ADI */ ! input arguments ! type(block_data), pointer, intent(inout) :: pblock ! local variables ! integer(kind=4), dimension(3) :: dm integer :: i, j, k real :: dx, dy, dxh, dyh, rc, rl, ru, ds, dl, dr ! local arrays ! real, dimension(:), allocatable :: x, y ! !------------------------------------------------------------------------------- ! ! allocate coordinates ! allocate(x(im)) allocate(y(jm)) ! calculate cell sizes ! dx = (pblock%meta%xmax - pblock%meta%xmin) / in dy = (pblock%meta%ymax - pblock%meta%ymin) / jn dxh = 0.5d0 * dx dyh = 0.5d0 * dy ds = dx * dy ! generate coordinates ! x(:) = ((/(i, i = 1, im)/) - ng) * dx - dxh + pblock%meta%xmin y(:) = ((/(j, j = 1, jm)/) - ng) * dy - dyh + pblock%meta%ymin ! set variables ! pblock%u(idn,:,:,:) = dens pblock%u(imx,:,:,:) = 0.0d0 pblock%u(imy,:,:,:) = 0.0d0 pblock%u(imz,:,:,:) = 0.0d0 ! set initial pressure ! do j = 1, jm do i = 1, im rc = x(i) + y(j) rl = rc - dxh - dyh ru = rc + dxh + dyh if (ru .le. rmid) then pblock%u(idn,i,j,:) = 0.125d0 #ifdef ADI pblock%u(ien,i,j,:) = gammam1i * 0.140d0 #endif /* ADI */ else if (rl .ge. rmid) then pblock%u(idn,i,j,:) = 1.0d0 #ifdef ADI pblock%u(ien,i,j,:) = gammam1i #endif /* ADI */ else if (rc .ge. rmid) then dl = 0.125d0 * (rmid - rl)**2 / ds dr = 1.0d0 - dl else dr = 0.125d0 * (ru - rmid)**2 / ds dl = 1.0d0 - dr endif pblock%u(idn,i,j,:) = 0.125d0 * dl + dr #ifdef ADI pblock%u(ien,i,j,:) = gammam1i * (0.140d0 * dl + dr) #endif /* ADI */ endif end do end do ! deallocate coordinates ! deallocate(x) deallocate(y) !------------------------------------------------------------------------------- ! end subroutine init_implosion ! !=============================================================================== ! ! init_binaries: subroutine initializes the variables for the binary star ! problem ! !=============================================================================== ! subroutine init_binaries(pblock) use blocks , only : block_data use config , only : ng, in, jn, kn, im, jm, km, dens, pres, dnfac, dnrat & , x1c, y1c, z1c, r1c, x2c, y2c, z2c, r2c, v1ini, v2ini & , csnd2, gamma, gammam1i use variables, only : idn, imx, imy, imz #ifdef ADI use variables, only : ien #endif /* ADI */ ! input arguments ! type(block_data), pointer, intent(inout) :: pblock ! local variables ! integer :: i, j, k real :: dx, dy, dz, dnamb, enamb, ekin real :: dnstar1, enstar1, x1l, y1l, z1l, r1 real :: dnstar2, enstar2, x2l, y2l, z2l, r2 ! local arrays ! real, dimension(:), allocatable :: x, y, z ! !------------------------------------------------------------------------------- ! ! calculate pressure from sound speed ! #ifdef ISO pres = csnd2 * dens #endif /* ISO */ #ifdef ADI pres = csnd2 * dens / gamma #endif /* ADI */ ! calculate parameters ! dnamb = dens dnstar2 = dnamb*dnfac dnstar1 = dnstar2*dnrat enamb = gammam1i*pres enstar1 = enamb*dnfac enstar2 = enstar1/dnrat ! allocate coordinates ! allocate(x(im)) allocate(y(jm)) allocate(z(km)) ! calculate cell sizes ! dx = (pblock%meta%xmax - pblock%meta%xmin) / in dy = (pblock%meta%ymax - pblock%meta%ymin) / jn #if NDIMS == 3 dz = (pblock%meta%zmax - pblock%meta%zmin) / kn #else /* NDIMS == 3 */ dz = 1.0 #endif /* NDIMS == 3 */ ! generate coordinates ! x(:) = ((/(i, i = 1, im)/) - ng - 0.5) * dx + pblock%meta%xmin y(:) = ((/(j, j = 1, jm)/) - ng - 0.5) * dy + pblock%meta%ymin #if NDIMS == 3 z(:) = ((/(k, k = 1, km)/) - ng - 0.5) * dz + pblock%meta%zmin #else /* NDIMS == 3 */ z(1) = 0.0 z1l = 0.0 z2l = 0.0 #endif /* NDIMS == 3 */ ! set variables ! pblock%u(idn,:,:,:) = dnamb pblock%u(imx,:,:,:) = 0.0d0 pblock%u(imy,:,:,:) = 0.0d0 pblock%u(imz,:,:,:) = 0.0d0 #ifdef ADI pblock%u(ien,:,:,:) = enamb #endif /* ADI */ ! set initial pressure ! do k = 1, km #if NDIMS == 3 z1l = z(k) - z1c z2l = z(k) - z2c #endif /* NDIMS == 3 */ do j = 1, jm y1l = y(j) - y1c y2l = y(j) - y2c do i = 1, im x1l = x(i) - x1c x2l = x(i) - x2c r1 = sqrt(x1l**2 + y1l**2 + z1l**2) r2 = sqrt(x2l**2 + y2l**2 + z2l**2) if (r1 .le. r1c) then pblock%u(idn,i,j,k) = dnstar1 pblock%u(imx,i,j,k) = dnstar1*v1ini*x1l pblock%u(imy,i,j,k) = dnstar1*v1ini*y1l #if NDIMS == 3 pblock%u(imz,i,j,k) = dnstar1*v1ini*z1l #endif /* NDIMS == 3 */ ekin = 0.5 * dnstar1 * v1ini**2 * (x1l**2 + y1l**2 + z1l**2) #ifdef ADI pblock%u(ien,i,j,k) = enstar1 + ekin #endif /* ADI */ endif if (r2 .le. r2c) then pblock%u(idn,i,j,k) = dnstar2 pblock%u(imx,i,j,k) = dnstar2*v2ini*x2l pblock%u(imy,i,j,k) = dnstar2*v2ini*y2l #if NDIMS == 3 pblock%u(imz,i,j,k) = dnstar2*v2ini*z2l #endif /* NDIMS == 3 */ ekin = 0.5 * dnstar2 * v2ini**2 * (x2l**2 + y2l**2 + z2l**2) #ifdef ADI pblock%u(ien,i,j,k) = enstar2 + ekin #endif /* ADI */ endif end do end do end do ! deallocate coordinates ! deallocate(x) deallocate(y) deallocate(z) !------------------------------------------------------------------------------- ! end subroutine init_binaries ! !=============================================================================== ! ! init_reconnection: subroutine initializes the variables for the reconnection ! problem ! !=============================================================================== ! subroutine init_reconnection(pblock) use blocks , only : block_data use config , only : in, jn, kn, im, jm, km, ng & , xmin, xmax, dens, pres, bamp, bper, ydel, ycut use scheme , only : prim2cons use variables, only : nvr, nqt use variables, only : idn, ivx, ivy, ivz #ifdef ADI use variables, only : ipr #endif /* ADI */ #ifdef MHD use variables, only : ibx, iby, ibz #ifdef FLUXCT use variables, only : icx, icy, icz #endif /* FLUXCT */ #ifdef GLM use variables, only : iph #endif /* GLM */ #endif /* MHD */ ! input arguments ! type(block_data), pointer, intent(inout) :: pblock ! local variables ! integer(kind=4), dimension(3) :: dm integer :: i, j, k real :: xlen, dx, dy, dz ! local arrays ! real, dimension(im) :: x real, dimension(jm) :: y real, dimension(km) :: z real, dimension(nvr,im) :: q, u ! parameters ! real, parameter :: pi = 3.1415926535897931159979634685442d0 ! !------------------------------------------------------------------------------- ! ! calculate the length of the box ! xlen = xmax - xmin ! calculate the cell sizes ! dx = (pblock%meta%xmax - pblock%meta%xmin) / in dy = (pblock%meta%ymax - pblock%meta%ymin) / jn #if NDIMS == 3 dz = (pblock%meta%zmax - pblock%meta%zmin) / kn #else /* NDIMS == 3 */ dz = 1.0 #endif /* NDIMS == 3 */ ! generate the coordinates ! x(:) = ((/(i, i = 1, im)/) - ng - 0.5) * dx + pblock%meta%xmin y(:) = ((/(j, j = 1, jm)/) - ng - 0.5) * dy + pblock%meta%ymin #if NDIMS == 3 z(:) = ((/(k, k = 1, km)/) - ng - 0.5) * dz + pblock%meta%zmin #else /* NDIMS == 3 */ z(1) = 0.0 #endif /* NDIMS == 3 */ ! set variables ! q(idn,:) = dens q(ivx,:) = 0.0d0 q(ivy,:) = 0.0d0 q(ivz,:) = 0.0d0 #ifdef ADI q(ipr,:) = pres #endif /* ADI */ #ifdef MHD q(ibx,:) = 0.0d0 q(iby,:) = 0.0d0 q(ibz,:) = 0.0d0 #ifdef FLUXCT q(ibx,:) = 0.0d0 q(iby,:) = 0.0d0 q(ibz,:) = 0.0d0 #endif /* FLUXCT */ #ifdef GLM q(iph,:) = 0.0d0 #endif /* GLM */ #endif /* MHD */ ! set the initial profiles ! do k = 1, km do j = 1, jm ! initialize the magnetic field components ! do i = 1, im q(ibx,i) = bamp * tanh(y(j) / ydel) q(iby,i) = bper * sin(pi * x(i) / xlen) & * exp(- 0.5d0 * (y(j) / ycut)**2) end do ! convert primitive variables to conserved ! call prim2cons(im, q(:,:), u(:,:)) ! copy conservative variables to the current block ! pblock%u(1:nqt,1:im,j,k) = u(1:nqt,1:im) end do end do ! !------------------------------------------------------------------------------- ! end subroutine init_reconnection #ifdef SHAPE ! !=============================================================================== ! ! shape_binaries: subroutine initializes the variables for the binary star ! problem ! !=============================================================================== ! subroutine shape_binaries(pblock, du) use blocks , only : block_data use config , only : ng, in, jn, kn, im, jm, km, dens, pres, dnfac, dnrat & , x1c, y1c, z1c, r1c, x2c, y2c, z2c, r2c & , csnd2, gamma, gammam1i use variables, only : idn, imx, imy, imz, ien ! input arguments ! type(block_data), pointer, intent(inout) :: pblock real, dimension(:,:,:,:) , intent(inout) :: du ! local variables ! integer :: i, j, k real :: dx, dy, dz real :: x1l, y1l, z1l, r1 real :: x2l, y2l, z2l, r2 ! local arrays ! real, dimension(:), allocatable :: x, y, z ! !------------------------------------------------------------------------------- ! ! allocate coordinates ! allocate(x(im)) allocate(y(jm)) allocate(z(km)) ! calculate cell sizes ! dx = (pblock%meta%xmax - pblock%meta%xmin) / in dy = (pblock%meta%ymax - pblock%meta%ymin) / jn #if NDIMS == 3 dz = (pblock%meta%zmax - pblock%meta%zmin) / kn #else /* NDIMS == 3 */ dz = 1.0 #endif /* NDIMS == 3 */ ! generate coordinates ! x(:) = ((/(i, i = 1, im)/) - ng - 0.5) * dx + pblock%meta%xmin y(:) = ((/(j, j = 1, jm)/) - ng - 0.5) * dy + pblock%meta%ymin #if NDIMS == 3 z(:) = ((/(k, k = 1, km)/) - ng - 0.5) * dz + pblock%meta%zmin #else /* NDIMS == 3 */ z(1) = 0.0 z1l = 0.0 z2l = 0.0 #endif /* NDIMS == 3 */ ! reset update ! do k = 1, km #if NDIMS == 3 z1l = z(k) - z1c z2l = z(k) - z2c #endif /* NDIMS == 3 */ do j = 1, jm y1l = y(j) - y1c y2l = y(j) - y2c do i = 1, im x1l = x(i) - x1c x2l = x(i) - x2c r1 = sqrt(x1l**2 + y1l**2 + z1l**2) r2 = sqrt(x2l**2 + y2l**2 + z2l**2) if (r1 .le. r1c) then du(:,i,j,k) = 0.0 endif if (r2 .le. r2c) then du(:,i,j,k) = 0.0 endif end do end do end do ! deallocate coordinates ! deallocate(x) deallocate(y) deallocate(z) !------------------------------------------------------------------------------- ! end subroutine shape_binaries #endif /* SHAPE */ ! !=============================================================================== ! ! check_ref: function checks refinement criterium and returns +1 if ! the criterium fullfiled and block is selected for ! refinement, 0 there is no need for refinement, and -1 if ! block is selected for refinement ! !=============================================================================== ! function check_ref(pblock) use blocks , only : block_data use config , only : im, jm, km, ibl, ieu, jbl, jeu, kbl, keu & , crefmin, crefmax use scheme , only : cons2prim use variables, only : nvr, nqt use variables, only : idn #ifdef ADI use variables, only : ipr #endif /* ADI */ #ifdef MHD use variables, only : ibx, iby, ibz #endif /* MHD */ ! input arguments ! type(block_data), pointer, intent(inout) :: pblock ! return variable ! integer(kind=1) :: check_ref ! local variables ! integer :: i, j, k real :: dpmax real :: dnl, dnr, ddndx, ddndy, ddndz, ddn #ifdef ADI real :: prl, prr, dprdx, dprdy, dprdz, dpr #endif /* ADI */ #ifdef MHD real :: bxl, bxr, dbxdx, dbxdy, dbxdz, dbx real :: byl, byr, dbydx, dbydy, dbydz, dby real :: bzl, bzr, dbzdx, dbzdy, dbzdz, dbz #endif /* MHD */ ! local arrays ! real, dimension(nvr,im) :: u, q real, dimension(im,jm,km) :: dn #ifdef ADI real, dimension(im,jm,km) :: pr #endif /* ADI */ #ifdef MHD real, dimension(im,jm,km) :: bx, by, bz #endif /* MHD */ ! !------------------------------------------------------------------------------- ! ! convert conserved variables to primitive ones ! do k = 1, km do j = 1, jm dn(1:im,j,k) = pblock%u(idn,1:im,j,k) #ifdef ADI u(1:nqt,1:im) = pblock%u(1:nqt,1:im,j,k) call cons2prim(im, u(:,:), q(:,:)) pr(1:im,j,k) = q(ipr,1:im) #endif /* ADI */ #ifdef MHD bx(1:im,j,k) = pblock%u(ibx,1:im,j,k) by(1:im,j,k) = pblock%u(iby,1:im,j,k) bz(1:im,j,k) = pblock%u(ibz,1:im,j,k) #endif /* MHD */ end do end do ! reset indicators ! dpmax = 0.0d0 ddn = 0.0d0 #ifdef ADI dpr = 0.0d0 #endif /* ADI */ #ifdef MHD dbx = 0.0d0 dby = 0.0d0 dbz = 0.0d0 #endif /* MHD */ ! check gradients of selected variables ! do k = kbl, keu do j = jbl, jeu do i = ibl, ieu ! density ! dnl = dn(i-1,j,k) dnr = dn(i+1,j,k) ddndx = abs(dnr - dnl) / (dnr + dnl) dnl = dn(i,j-1,k) dnr = dn(i,j+1,k) ddndy = abs(dnr - dnl) / (dnr + dnl) #if NDIMS == 2 ddn = sqrt(ddndx**2 + ddndy**2) #else /* NDIMS == 2 */ dnl = dn(i,j,k-1) dnr = dn(i,j,k+1) ddndz = abs(dnr - dnl) / (dnr + dnl) ddn = sqrt(ddndx**2 + ddndy**2 + ddndz**2) #endif /* NDIMS == 2 */ ! update the indicator ! dpmax = max(dpmax, ddn) #ifdef ADI ! pressure ! prl = pr(i-1,j,k) prr = pr(i+1,j,k) dprdx = abs(prr - prl) / (prr + prl) prl = pr(i,j-1,k) prr = pr(i,j+1,k) dprdy = abs(prr - prl) / (prr + prl) #if NDIMS == 2 dpr = sqrt(dprdx**2 + dprdy**2) #else /* NDIMS == 2 */ prl = pr(i,j,k-1) prr = pr(i,j,k+1) dprdz = abs(prr - prl) / (prr + prl) dpr = sqrt(dprdx**2 + dprdy**2 + dprdz**2) #endif /* NDIMS == 2 */ ! update the indicator ! dpmax = max(dpmax, dpr) #endif /* ADI */ #ifdef MHD ! X magnetic component ! bxl = bx(i-1,j,k) bxr = bx(i+1,j,k) dbxdx = abs(bxr - bxl) / max(1.0d-16, abs(bxr) + abs(bxl)) bxl = bx(i,j-1,k) bxr = bx(i,j+1,k) dbxdy = abs(bxr - bxl) / max(1.0d-16, abs(bxr) + abs(bxl)) #if NDIMS == 2 dbx = sqrt(dbxdx**2 + dbxdy**2) #else /* NDIMS == 2 */ bxl = bx(i,j,k-1) bxr = bx(i,j,k+1) dbxdz = abs(bxr - bxl) / max(1.0d-16, abs(bxr) + abs(bxl)) dbx = sqrt(dbxdx**2 + dbxdy**2 + dbxdz**2) #endif /* NDIMS == 2 */ ! Y magnetic component ! byl = by(i-1,j,k) byr = by(i+1,j,k) dbydx = abs(byr - byl) / max(1.0d-16, abs(byr) + abs(byl)) byl = by(i,j-1,k) byr = by(i,j+1,k) dbydy = abs(byr - byl) / max(1.0d-16, abs(byr) + abs(byl)) #if NDIMS == 2 dby = sqrt(dbydx**2 + dbydy**2) #else /* NDIMS == 2 */ byl = by(i,j,k-1) byr = by(i,j,k+1) dbydz = abs(byr - byl) / max(1.0d-16, abs(byr) + abs(byl)) dby = sqrt(dbydx**2 + dbydy**2 + dbydz**2) #endif /* NDIMS == 2 */ ! Z magnetic component ! bzl = bz(i-1,j,k) bzr = bz(i+1,j,k) dbzdx = abs(bzr - bzl) / max(1.0d-16, abs(bzr) + abs(bzl)) bzl = bz(i,j-1,k) bzr = bz(i,j+1,k) dbzdy = abs(bzr - bzl) / max(1.0d-16, abs(bzr) + abs(bzl)) #if NDIMS == 2 dbz = sqrt(dbzdx**2 + dbzdy**2) #else /* NDIMS == 2 */ bzl = bz(i,j,k-1) bzr = bz(i,j,k+1) dbzdz = abs(bzr - bzl) / max(1.0d-16, abs(bzr) + abs(bzl)) dbz = sqrt(dbzdx**2 + dbzdy**2 + dbzdz**2) #endif /* NDIMS == 2 */ ! update the indicator ! dpmax = max(dpmax, dbx, dby, dbz) #endif /* MHD */ end do end do end do ! return the refinement flag depending on the condition value ! check_ref = 0 if (dpmax .ge. crefmax) then check_ref = 1 end if if (dpmax .le. crefmin) then check_ref = -1 end if return !------------------------------------------------------------------------------- ! end function check_ref !=============================================================================== ! end module