filval.f90 File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	filval (val, mitot, mjtot, dx, dy, level, time, mic, mjc, xleft, xright, ybot, ytop, nvar, mptr, ilo, ihi, jlo, jhi, aux, naux)
	Fill grid mptr on level level by copying values from OLD level level grids if available, otherwise by interpolating values from coarser grids. More...
subroutine	dumpaux (aux, naux, mitot, mjtot)

Function/Subroutine Documentation

dumpaux()

subroutine dumpaux	(	real(kind=8), dimension(naux,mitot,mjtot)	aux,
		integer	naux,
		integer	mitot,
		integer	mjtot
	)

Definition at line 219 of file filval.f90.

   implicit none
   real(kind=8) :: aux(naux,mitot,mjtot)
   integer :: naux,mitot,mjtot,i,j,iaux

   do j = 1, mjtot 
   do i = 1, mitot 
      write(*,444) i,j,(aux(iaux,i,j),iaux=1,naux)
 444  format(2i4,5e12.5)
   end do
   end do

filval()

subroutine filval	(	real(kind=8), dimension(nvar,mitot,mjtot), intent(inout)	val,
		integer, intent(in)	mitot,
		integer, intent(in)	mjtot,
		real(kind=8), intent(in)	dx,
		real(kind=8), intent(in)	dy,
		integer, intent(in)	level,
		real(kind=8), intent(in)	time,
		integer, intent(in)	mic,
		integer, intent(in)	mjc,
		real(kind=8), intent(in)	xleft,
		real(kind=8), intent(in)	xright,
		real(kind=8), intent(in)	ybot,
		real(kind=8), intent(in)	ytop,
		integer, intent(in)	nvar,
		integer, intent(in)	mptr,
		integer, intent(in)	ilo,
		integer, intent(in)	ihi,
		integer, intent(in)	jlo,
		integer, intent(in)	jhi,
		real(kind=8), dimension(naux,mitot,mjtot), intent(inout)	aux,
		integer, intent(in)	naux
	)

Fill grid mptr on level level by copying values from OLD level level grids if available, otherwise by interpolating values from coarser grids.

Definition at line 6 of file filval.f90.

References amr_module::alloc, bc2amr(), fixcapaq(), icall(), intcopy(), amr_module::intratx, amr_module::intraty, amr_module::iregsz, amr_module::jregsz, amr_module::mcapa, amr_module::needs_to_be_set, amr_module::newstl, amr_module::nghost, amr_module::outunit, preicall(), preintcopy(), setaux(), amr_module::spheredom, amr_module::xlower, amr_module::xperdom, amr_module::xupper, amr_module::ylower, amr_module::yperdom, and amr_module::yupper.

Referenced by gfixup().

    use amr_module, only: xlower, ylower, intratx, intraty, nghost, xperdom
    use amr_module, only: yperdom, spheredom, xupper, yupper, alloc
    use amr_module, only: outunit, needs_to_be_set, mcapa
    use amr_module, only: newstl, iregsz, jregsz
    
    implicit none

    ! Input
    integer, intent(in) :: mitot, mjtot, level, mic, mjc, nvar, mptr, ilo, ihi
    integer, intent(in) :: jlo, jhi, naux
    real(kind=8), intent(in) :: dx, dy, time, xleft, xright, ybot, ytop

    ! Output
    real(kind=8), intent(in out) :: val(nvar,mitot,mjtot), aux(naux,mitot,mjtot)

    ! Local storage
    integer :: refinement_ratio_x, refinement_ratio_y, iclo, jclo, ichi, jchi, ng
    integer :: ivar, i, j, ico, jco, ifine, jfine, nx, ny
    real(kind=8) :: valc(nvar,mic,mjc), auxc(naux,mic,mjc)
    real(kind=8) :: dx_coarse, dy_coarse, xl, xr, yb, yt, area
    real(kind=8) :: s1m, s1p, slopex, slopey, xoff, yoff
    real(kind=8) :: fliparray((mitot+mjtot)*nghost*(nvar+naux))
    real(kind=8) :: setflags(mitot,mjtot),maxauxdif,aux2(naux,mitot,mjtot)
    integer :: mjb
    integer :: jm, im, nm 
    logical :: sticksoutxfine, sticksoutyfine,sticksoutxcrse,sticksoutycrse
    
    !for setaux timing
    integer :: clock_start, clock_finish, clock_rate
    real(kind=8) :: cpu_start, cpu_finish


    ! External function definitions
    real(kind=8) :: get_max_speed


    refinement_ratio_x = intratx(level-1)
    refinement_ratio_y = intraty(level-1)
    dx_coarse  = dx * refinement_ratio_x
    dy_coarse  = dy * refinement_ratio_y
    xl      = xleft  - dx_coarse
    xr      = xright + dx_coarse
    yb      = ybot   - dy_coarse
    yt      = ytop   + dy_coarse

    ! if topo not yet final then aux is set outside filval (in gfixup)
    ! and so aux has real data already, (ie dont overwrite here)

    ! set integer indices for coarser patch enlarged by 1 cell
    ! (can stick out of domain). proper nesting will insure this one
    ! call is sufficient.
    iclo   = ilo / refinement_ratio_x - 1
    jclo   = jlo / refinement_ratio_y - 1
    ichi   = (ihi + 1) / refinement_ratio_x - 1 + 1
    jchi   = (jhi + 1) / refinement_ratio_y - 1 + 1
    ng     = 0

    sticksoutxfine = ( (ilo .lt. 0) .or. (ihi .ge. iregsz(level)))
    sticksoutyfine = ( (jlo .lt. 0) .or. (jhi .ge. jregsz(level)))
    sticksoutxcrse = ((iclo .lt. 0) .or. (ichi .ge. iregsz(level-1)))
    sticksoutycrse = ((jclo .lt. 0) .or. (jchi .ge. jregsz(level-1)))

    if (naux == 0) then
        if ((xperdom .and. sticksoutxcrse).or. (yperdom.and.sticksoutycrse)  .or. spheredom) then
            call preintcopy(valc,mic,mjc,nvar,iclo,ichi,jclo,jchi,level-1,fliparray)
        else
            call intcopy(valc,mic,mjc,nvar,iclo,ichi,jclo,jchi,level-1,1,1)
        endif
    else  
        ! intersect grids and copy all (soln and aux)
        auxc(1,:,:) = needs_to_be_set
        if ((xperdom .and.sticksoutxcrse) .or. (yperdom.and.sticksoutycrse) .or. spheredom) then
            call preicall(valc,auxc,mic,mjc,nvar,naux,iclo,ichi,jclo,jchi, &
                          level-1,fliparray)
        else
            call icall(valc,auxc,mic,mjc,nvar,naux,iclo,ichi,jclo,jchi,level-1,1,1)
        endif
!!$        do i = 1, mic
!!$        do j = 1, mjc
!!$          if (auxc(1,:,:) == NEEDS_TO_BE_SET) then
!!$             write(*,*)" *** coarsenened new fine grid not completely set from previously"  &
!!$                       "existing coarse grids ***"
!!$             stop
!!$          endif
!!$        end do
!!$        end do
           ! no ghost cells on coarse enlarged patch. set any remaining
           ! vals. should only be bcs that stick out of domain.
           call setaux(ng,mic,mjc,xl,yb,dx_coarse,dy_coarse,naux,auxc)
    endif

    call bc2amr(valc,auxc,mic,mjc,nvar,naux,dx_coarse,dy_coarse,level-1,time,xl,xr,yb, &
                yt,xlower,ylower,xupper,yupper,xperdom,yperdom,spheredom)



!  NOTE change in order of code.  Since the interp from coarse to fine needs the aux
!       arrays set already, the fine copy is done first, to set up the aux arrays.
!       we can do this since we have the flag array to test where to overwrite.

!  SO this is no longer overwriting but setting for the first time.
! overwrite interpolated values with fine grid values, if available.
    nx = mitot - 2*nghost
    ny = mjtot - 2*nghost

    if (naux .gt. 0) then 
!       ## NEEDS_TO_BE_SET is signal that aux array not set.
!       ## after calling icall to copy aux from other grids
!       ## any remaining NEEDS_TO_BE_SET signals will be set in setaux.
!       ## it also signals where soln was copied, so it wont be
!       ## overwritten with coarse grid interpolation
        aux(1,:,:) = needs_to_be_set  ! indicates fine cells not yet set. 

        if ((xperdom.and.sticksoutxfine) .or. (yperdom.and.sticksoutyfine) .or. spheredom) then
            call preicall(val,aux,mitot,mjtot,nvar,naux,ilo-nghost,ihi+nghost, & 
                          jlo-nghost,jhi+nghost,level,fliparray)
        else
            call icall(val,aux,mitot,mjtot,nvar,naux,ilo-nghost,ihi+nghost,  &
                      jlo-nghost,jhi+nghost,level,1,1)   
        endif
        setflags = aux(1,:,:)   ! save since will overwrite in setaux when setting all aux vals
           ! need this so we know where to use coarse grid to set fine solution w/o overwriting
           ! set remaining aux vals not set by copying from prev existing grids
        call setaux(nghost,nx,ny,xleft,ybot,dx,dy,naux,aux)
    else ! either no aux exists, or cant reuse yet  
         ! so only call intcopy (which copies soln) and not icall.
         ! in this case flag q(1,:) to NEEDS_TO_BE_SET flag so wont be overwritten
         ! by coarse grid interp.  this is needed due to reversing order of
         ! work - first copy from fine grids, then interpolate from coarse grids
        val(1,:,:) = needs_to_be_set
        if ((xperdom.and.sticksoutxfine) .or. (yperdom.and.sticksoutyfine) .or. spheredom) then
            call preintcopy(val,mitot,mjtot,nvar,ilo-nghost,ihi+nghost,     &
                            jlo-nghost,jhi+nghost,level,fliparray)
        else
            call intcopy(val,mitot,mjtot,nvar,ilo-nghost,ihi+nghost,  &
                         jlo-nghost,jhi+nghost,level,1,1)   
        endif
        setflags = val(1,:,:)  ! remaining flags signals need to set
    endif

   
    ! Prepare slopes - use min-mod limiters

    do j=2, mjc-1
     do i=2, mic-1
       do ivar = 1, nvar
 
            s1p = valc(ivar,i+1,j) - valc(ivar,i,j)
            s1m = valc(ivar,i,j)   - valc(ivar,i-1,j)
            slopex = min(abs(s1p), abs(s1m)) &
                         * sign(1.d0,valc(ivar,i+1,j) - valc(ivar,i-1,j))
            ! if there's a sign change, set slope to 0.
            if ( s1m*s1p <=  0.d0) slopex = 0.d0

            s1p = valc(ivar,i,j+1) - valc(ivar,i,j)
            s1m = valc(ivar,i,j)   - valc(ivar,i,j-1)
            slopey = min(abs(s1p), abs(s1m))  &
                         * sign(1.0d0, valc(ivar,i,j+1) - valc(ivar,i,j-1))
            if ( s1m*s1p <= 0.d0)  slopey = 0.d0

            ! Interpolate from coarse cells to fine grid to find depth
             do jco = 1,refinement_ratio_y
               yoff = (real(jco,kind=8) - 0.5d0) / refinement_ratio_y - 0.5d0
               jfine = (j-2) * refinement_ratio_y + nghost + jco

               do ico = 1,refinement_ratio_x
                 xoff = (real(ico,kind=8) - 0.5d0) / refinement_ratio_x - 0.5d0
                 ifine = (i-2) * refinement_ratio_x + nghost + ico

                 if (setflags(ifine,jfine) .eq. needs_to_be_set) then
                    val(ivar,ifine,jfine) = valc(ivar,i,j) + xoff*slopex + yoff*slopey
                 endif

               end do
            end do

       enddo !end of ivar loop
     enddo !end of coarse i loop
    enddo !end of coarse j loop

    ! adjust to conserve kappa*q, but only where coarse grid was interpolated
    ! so now need to pass setflags to this subr.
    if (mcapa .ne. 0) then  
        call fixcapaq(val,aux,mitot,mjtot,valc,auxc,mic,mjc,nvar,naux,level-1,setflags)
    endif
 
!!$! CHECK BY CALLING SETAUX AND SETTING ALL, THEN DIFFING
!!$   mjb = 0
!!$   if (naux .gt. 0  .and. mjb .eq. 1) then
!!$      aux2(1,:,:) = NEEDS_TO_BE_SET   ! indicates fine cells not yet set
!!$      call setaux(nghost,nx,ny,xleft,ybot,dx,dy,naux,aux2)
!!$      maxauxdif = 1.d-13
!!$      do i = 1, mitot
!!$      do j = 1, mjtot
!!$         if (abs(aux(1,i,j)-aux2(1,i,j)) .gt. maxauxdif) then
!!$            maxauxdif = abs(aux(1,i,j)-aux2(1,i,j))
!!$            write(*,444)i,j,aux(1,i,j),aux2(1,i,j),maxauxdif
!!$444         format("i,j = ",2i4," auxs ",2e15.7," maxauxdif ",e12.5)
!!$         endif
!!$      end do
!!$      end do
!!$      if (maxauxdif .gt. 2.d-13) then
!!$         write(*,*)" maxauxdif = ",maxauxdif," with mitot,mjtot ",mitot,mjtot, &
!!$              " on grid ",mptr," level ",level
!!$      endif
!!$   endif

Here is the call graph for this function:

Here is the caller graph for this function: