!!
!! Luke McCulloch
!! solver.f90
!! 11-9-2011
!! Qasi 1D Euler Solver

PROGRAM solver

  use precise, only : defaultp   ! Module to handle precision
  use GEO                        ! Module to write the Points on the surface
  !use Swafftridag                ! Swaffs version
  use blocktri

  IMPLICIT NONE

  integer, parameter :: WP=defaultp
  real(wp), parameter :: e=2.718281828459045
  REAL(wp), PARAMETER :: pi=4.0*ATAN(1.0)
  INTEGER, DIMENSION(6), PARAMETER :: it1 = (/ 1, 5, 10, 15, 40, 50 /)   ! GNU output times

  integer::count_0, count1, count2, count_rate, count_max, walltime, tstart, tend

  Integer :: NI, i, j, k, t, NT, m, mmax
  Integer :: min, max
  Real(WP) :: dx, L, dt, norm, freestreamMach, gamma
  real(WP) :: start_time, energy, pressure
  REAL(WP), DIMENSION(3,3) :: Identity
  Real(WP), Allocatable, Dimension(:,:,:) :: Q, Qf, qc
  Real(WP), Allocatable, Dimension(:,:,:) :: dfdq, dhdq
  Real(WP), Allocatable, Dimension(:,:) :: H, F
  REAL(wp), Allocatable, DIMENSION(:) :: X, r, S, Vol, deltaS, deltaVol, p
  REAL(wp), Allocatable, DIMENSION(:) :: rface, Sface
  REAL(wp), Allocatable, DIMENSION(:,:,:) :: am, bm, cm
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: L2, L2norm, newtonL2norm
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: deltaQ, RHS

  !! FV variables
  Integer :: NV
  REAL(wp), Allocatable, DIMENSION(:) :: V
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: vU

  !*Test Case*!
  REAL(WP), DIMENSION(3,3,4) :: Dtest
  REAL(WP), DIMENSION(3,3,4) :: Utest
  REAL(WP), DIMENSION(3,3,4) :: Ltest
  REAL(WP), DIMENSION(3,4) :: Btest
  REAL(WP), DIMENSION(3,4) :: Xtest

  ! Simple start up message
  write(6,*) ''
  Write(6,*) ''
  write(6,*) '-----------------------------------------------------'
  write(6,*) '-----------------------------------------------------'
  write(6,*) '                                                     '
  Write(6,*) '                                                     '
  WRITE(6,'(A)') '  CFD1 Quasi 1D Euler Solver                     '
  Write(6,*)     ' 11/9/2011 Implementation By Luke McCulloch      '
  write(6,*) '                                                     '
  Write(6,*) '                                                     '
  write(6,*) '-----------------------------------------------------'
  write(6,*) '-----------------------------------------------------'

  !Umx=-1.0e10

  dx=0.2
  L=10.
  NV=int(real(L/dx))
  NV=NV+1
  NI=NV+1
  dt = 0.5
  NT=500

  NT= NT+1
  Allocate( X(NI) )

!!-----------------------------
  Allocate( Q(3,NI,0:nt) )
  Allocate( Qf(3,NV,0:nt) )
  Allocate( qc(3,NI,0:nt) )
  !*Big Chance - there are really only 51 faces*!
  Allocate( F(3,NV) )
  Allocate( H(3,NI) )

  !*Should be NI-2*!
  Allocate( deltaQ(3,NI) )
  Allocate( RHS(3,NI) )

  !*Big Chance - there are really only 51 faces*!
  Allocate( dfdq(3,3,NV) )
  Allocate( dhdq(3,3,NI) )

  !!Allocate( rface(NV) )
  !!Allocate( Sface(NV) )
  !*r now = rface*!
  Allocate( r(NV) )
  Allocate( S(NV) )
  Allocate( Vol(NI) )
  Allocate( deltaS(NI) )
  Allocate( deltaVol(NI) )

  Allocate( P(NI) )

  !*Block Tri full matrices*!
  Allocate( am(3,3,NI-2) )
  Allocate( bm(3,3,NI-2) )
  Allocate( cm(3,3,NI-2) )

!!-----------------------------
  !Allocate( U(NI,NT) )
  !Allocate( Uexact(NI,NT) )

  Allocate( L2(NI,0:NT) )

  Allocate( L2norm(1,0:NT) )
  Allocate( newtonL2norm(0:NT,15) )

  Allocate( vU(NV,0:NT) )
  Allocate( V(NV) )

  NT= NT-1

  !* Subroutines to compute grid points  *!
  Call D1(NV, dx, V )   ! Face points
  Call V1(NI, dx, X)    ! Volume Centers

  !Check Points - Comment this in the full Version
  Write(6,'(AA)') 'Volume Centroids'
  do i=1,NI
     write(*,*) 'I, X(i)', i, X(i)
  end do
  Write(6,*) ''

  Write(6,'(AA)') 'Face Points'
  do i=1,NV
     write(*,*) 'I, V(i)', i, V(i)
  end do
  Write(6,*) ''
  !pause

  !* Identity Matrix *!
  Do j=1,3
     Do i=1,3
        Identity(i,j) = 0.0
     End do
  End do
  Identity(1,1) = 1.0
  Identity(2,2) = 1.0
  Identity(3,3) = 1.0
  !*-----------------*!

  ! x<0 @ i=1 so set x=0
     !!r(1)=1.398+0.347*tanh(-4.0)
  !* Compute r(x) *!
  Do i=1,NV
     r(i)=1.398+0.347*tanh(0.8*V(i)-4.0)
  End do

  Write(6,'(AA)') 'r Points'
  do i=1,NV
     write(*,*) 'I, r(i)', i, r(i)
  end do
  Write(6,*) ''
  !pause

  ! x<0 @ i=1 so set x=0
  !r(1)=1.398+0.347*tanh(-4.0)
  !* Compute r(x) *!
!!$  Do i=1,NV
!!$     rface(i)=1.398+0.347*tanh(0.8*V(i)-4.0)
!!$     Sface(i)=pi*rface(i)**2
!!$  End do

  !* Set the Cell Face Tube geometry  *!
  Do i=1,NV
     S(i)=pi*r(i)**2
  End do

  Do i=2,NI-1
     !*Frustum Volume*!
!!     if (i==2) then
!!        dx=dx/2.0
!!     end if
     Vol(i)=(pi*dx/3.0)*( (r(i)**2)+(r(i-1)**2)+r(i)*r(i-1) )
     deltaS(i)=S(i)-S(i-1)
     deltaVol(i)=Vol(i)
  End do
  deltaS(1)=0.0!deltaS(2)
  deltaVol(1)=0.0!deltaVol(2)
  deltaS(NI)=deltaS(NI-1)
  deltaVol(NI)=deltaVol(NI-1)

  do i=1,NI
     write(*,*) 'deltaS', deltaS(i)
  end do

  Write(6,*) 'setup inflow'
  freestreamMach=1.5
  gamma=1.4
  !* --------------- Compute Q inflow at volume centers and faces-------------- *!
  do i=1,NI
     q(1,i,0)=1.0
     q(2,i,0)=freestreamMach
     q(3,i,0)=(1./(gamma*(gamma-1.0))+0.5*freestreamMach**2)
  End do
  do i=1,NV
     qf(1,i,0)=0.5*(q(1,i,0)+q(1,i+1,0))
     qf(2,i,0)=0.5*(q(2,i,0)+q(2,i+1,0))
     qf(3,i,0)=0.5*(q(3,i,0)+q(3,i+1,0))
  end do
  !* End ---------------------------------------------*!
  p(1)=(gamma-1.0)*q(3,1,0)-0.5*(gamma-1.0)*(q(2,1,0)**2)/q(1,1,0)
  !* --------------- Compute F inflow --------------- *!
  f(1,1)=S(i)*qf(2,1,0)
  f(2,1)=S(i)*(((qf(2,1,0)**2)/qf(1,1,0))*(3.-gamma)/2.)+(gamma-1.0)*qf(3,1,0)
  f(3,1)=S(i)*(qf(2,1,0)/qf(1,1,0))*(gamma*qf(3,1,0) - 0.5*(gamma-1.0)*((qf(2,1,0)**2)/qf(1,1,0)))
  do j=1,3
     f(j,1)=S(1)*f(j,1)
  end do
  !* End ---------------------------------------------*!

  !* --------------- Compute H inflow --------------- *!
  h(1,1)=0.0
  h(2,1)=deltaS(1)*p(1)*freestreamMach
  !h(2,1)=freestreamMach
  h(3,1)=0.0
  !* End -------------------------------------------- *!
  !* End of the B.C. / I.V. portion------------------ *!

  !------------------------------------------------------------
  write(*,*) 'T=', 0
  t=0
  Do i=1,NI
     write(*,*) 'q1,q2,q3', q(1,i,t), q(2,i,t), q(3,i,t)
  End do
  write(*,*) ''
  !------------------------------------------------------------

  Write (*,*) '------------------Begin Implicit Euler Method--------------------------'
  ! max is the number of elements in the diagonal
  ! am is the subdiagonal
  ! bm is the diagonal
  ! cm is the superdiagonal

  !* Begin the time loop  *!
  Do t=0,NT

     !*Set Constant q RHS term for NM loop*!
     Do j=1,3
        do i=1,NI
           qc(j,i,t)=q(j,i,t)
        end do
     end do

     !*Newton's Method Iterative Loop*!
     do m=1,15
     norm=0.0

        !*Write Q on the faces*!
        do i=1,NV
           qf(1,i,t)=0.5*(q(1,i,t)+q(1,i+1,t))
           qf(2,i,t)=0.5*(q(2,i,t)+q(2,i+1,t))
           qf(3,i,t)=0.5*(q(3,i,t)+q(3,i+1,t))
        end do
        !* Enforce Boundary Nodes For Newton Loops*!
!!$        Do j=1,3
!!$           q(j,1,t)=q(j,1,0)
!!$           q(j,NI,t)=q(j,NI-1,t)
!!$           !qf(j,1,t)=qf(j,1,0)
!!$           !*The condition below "KILL" my solution*!
!!$           !qf(j,NV,t)=qf(j,NV-1,t)
!!$        End do

        !* Update F,H and Jacobians throughout the domain *!
        Do i=1,NV
           !* --------------- Compute F ---------------------------------------------------- *!
           pressure = (gamma-1.0)*(qf(3,i,t)-(0.5*(qf(2,i,t)**2)/qf(1,i,t)))
           energy = ((1.0/(gamma-1.0))*pressure/qf(1,i,t))+0.5*((qf(2,i,t)/qf(1,i,t))**2)
           f(1,i)=S(i)*qf(2,i,t)
           !f(2,i)=S(i)*(  ( ( (qf(2,i,t)**2)/qf(1,i,t) )*(3.0-gamma)/2.0 )+(gamma-1)*qf(3,i,t)  )
           f(2,i)=S(i)*(  ( ( (qf(2,i,t)**2)/qf(1,i,t) ) +pressure))
           !f(3,i)=S(i)*(qf(2,i,t)/qf(1,i,t))*(gamma*qf(3,i,t) - 0.5*(gamma-1)*((qf(2,i,t)**2)/qf(1,i,t)))
           f(3,i)=S(i)*(qf(2,i,t)/qf(1,i,t))*(qf(1,i,t)*energy+pressure)
           !* End ---------------------------------------------------------------------------*!
        End do
        Do i=1,NI
           !* --------------- Compute H ---------------------------------------------------- *!
           h(1,i)=0.0
           h(2,i)=deltaS(i)*((gamma-1.0)*q(3,i,t)-0.5*(gamma-1.0)*((q(2,i,t)**2)/q(1,i,t)))
           h(3,i)=0.0
           !* End ---------------------------------------------------------------------------*!
        End do

        !* Compute flux jacobians  *!
        Do i=1,NV
           !*  A=df/dq  *!
           dfdq(1,1,i)=0.0
           dfdq(1,2,i)=1.0
           dfdq(1,3,i)=0.0
           dfdq(2,1,i)=0.5*(gamma-3.0)*(qf(2,i,t)**2)/(qf(1,i,t)**2)
           dfdq(2,2,i)=(3.0-gamma)*qf(2,i,t)/qf(1,i,t)
           dfdq(2,3,i)=(gamma-1.0)
           pressure = (gamma-1.0)*(qf(3,i,t)-(0.5*(qf(2,i,t)**2)/qf(1,i,t)))
           energy = ((1.0/(gamma-1.0))*pressure/qf(1,i,t))+0.5*((qf(2,i,t)/qf(1,i,t))**2)
           !!dfdq(3,1,i)=(gamma-1.0)*(qf(2,i,t)**3/(qf(1,i,t)**3)) - qf(2,i,t)*qf(3,i,t)*(gamma)/(qf(1,i,t)**2)
           !dfdq(3,1,i)=-gamma*(qf(2,i,t)/qf(1,i,t))*energy+(gamma-1.0)*((qf(2,i,t)/qf(1,i,t))**3)

           dfdq(3,1,i)=-gamma*energy*qf(2,i,t)/qf(1,i,t)+(gamma-1.0)*((qf(2,i,t)/qf(1,i,t))**3)

           !!dfdq(3,2,i)=((1.0/qf(1,i,t))*(gamma*qf(3,i,t)-0.5*(gamma-1.0)*(qf(2,i,t)**2)/qf(1,i,t)))
           dfdq(3,2,i)=gamma*energy-(3.0*0.5)*(gamma-1.0)*((qf(2,i,t)/qf(1,i,t))**2)
           dfdq(3,3,i)=(gamma*qf(2,i,t)/qf(1,i,t))
        End do
        Do i=1,NI
           !*  A=dh/dq  *!
           dhdq(1,1,i)=0.0
           dhdq(1,2,i)=0.0
           dhdq(1,3,i)=0.0
           dhdq(2,1,i)=deltaS(i)*0.5*(gamma-1.0)*(q(2,i,t)**2)/(q(1,i,t)**2)
           dhdq(2,2,i)=deltaS(i)*(1.0-gamma)*q(2,i,t)/q(1,i,t)
           dhdq(2,3,i)=deltaS(i)*(gamma-1.0)
           dhdq(3,1,i)=0.0
           dhdq(3,2,i)=0.0
           dhdq(3,3,i)=0.0
        End do

        !--------------------------------------!
        !!*Set up the Block Tridagonal System*!!
        !   Beware: Indicies set such that     !
        !    Vbls follow convention            !
        !        which includes the            !
        !        out of scope                  !
        !         sub and super diagonals      !
        !         diagonals                    !
                   min=1
                   max=NI-2
        !--------------------------------------!

        !* Compute the subdiagonal *!
        do k=1,3
           do j=1,3
              do i=min+1,max
                 am(j,k,i)=-S(i)*dfdq(j,k,i)
                 am(j,k,min)=0.0   !Key to indici logic
              end do
           end do
        End do

!!$     do i=1,NI
!!$        do k=1,3
!!$           do j=1,3
!!$              write(*,*) 'am components', dt, deltaVol(i+1), S(i), dfdq(j,k,i), Vol(i)
!!$           end do
!!$        end do
!!$     end do

        !* Compute the main diagonal  *!
        do k=1,3
           do j=1,3
              do i=min,max
                 bm(j,k,i)= (2.0*deltaVol(i+1)/dt)*Identity(j,k) - &
                      S(i)*dfdq(j,k,i)+S(i+1)*dfdq(j,k,i+1) - &
                      2*dhdq(j,k,i+1)
              End do
           End Do
        End Do

        !* Compute the superdiagonal *!
        do k=1,3
           do j=1,3
              do i=min,max-1
                 cm(j,k,i)=S(i+1)*dfdq(j,k,i+1)
                 cm(j,k,max)=0.0   !Key to indici logic
              End do
           End Do
        End Do

        !* Compute the RHS *!
        do j=1,3
           do i=min,max
              RHS(j,i)= -2.0*(deltaVol(i+1)*((q(j,i+1,t)-qc(j,i+1,t))/dt)+(F(j,i+1)-F(j,i)-H(j,i+1)) )
              !write(*,*) 'deltaVoli Fi+1/2, Fi-1/2, Hi', deltaVol(i+1),F(j,i+1),F(j,i),H(j,i+1)
           End do
           !write(*,*)''
        end do

        !! Call block tri diagonal Solver
!!$        write(*,*) 'Elements into the solver'
!!$            do i=min,max
!!$        do j=1,3
!!$           do k=1,3
!!$
!!$                 write(*,*) j,k,i,' am=',am(j,k,i),'bm= ', bm(j,k,i),' cm=', cm(j,k,i)
!!$              End do
!!$           End do
!!$        End do
        Call solve (am,bm,cm,RHS,1,50)

        !* Sticking with block indices*!
        Do j=1,3
           Do i=min,max
              deltaQ(j,i+1)=RHS(j,i)
           End do
        End do

        !*BC, #5 in assignment*!
        Do j=1,3
           deltaQ(j,1)=0.0
           deltaQ(j,NI)=0.0
        end do

        !*-- Update Q --------------------------------------------------------------------*!
        !* Real Indicies *!
        Do j=1,3
           Do i=1,NI
              q(j,i,t)=deltaQ(j,i)+q(j,i,t)
           End Do
        End do

        !* Enforce Boundary Nodes For Newton Loops*!
        Do j=1,3
           q(j,1,t)=q(j,1,0)
           q(j,NI,t)=q(j,NI-1,t)
           qf(j,1,t)=qf(j,1,0)
           qf(j,NV,t)=qf(j,NV-1,t)
        End do

        !*Update Q on the faces*!
!!$        do i=1,NV
!!$           qf(1,i,t)=0.5*(q(1,i,t)+q(1,i+1,t))
!!$           qf(2,i,t)=0.5*(q(2,i,t)+q(2,i+1,t))
!!$           qf(3,i,t)=0.5*(q(3,i,t)+q(3,i+1,t))
!!$        end do
!!$
        !*-- Update norm --------------------------------------------------------------------*!
        !* Real Indicies *!
         norm=0.0
         Do i=2,NI-1
            norm = norm + (deltaQ(1,i)**2.+deltaQ(2,i)**2+deltaQ(3,i)**2)
         End Do
        !*-- End -------------------------------------------------------------------------*!
        L2norm(1,t)=sqrt(norm)/real(NI-2)
        newtonL2norm(t,m)=L2norm(1,t)

        !------------------------------------------------------------
        write(*,*) 'T=', t, 'm=',m
        Do i=1,NI
           write(*,*) 'r,q(1-3),deltq(1-3)', i, q(1,i,t), q(2,i,t), q(3,i,t), deltaQ(1,i), deltaQ(2,i), deltaQ(3,i)
        End do
        write(*,*) ''
        !------------------------------------------------------------

     !*End Newton's Method iteration*!
     End do

     !*Update the new time level cell centers*!
     Do j=1,3
        do i=1,NI
           q(j,i,t+1)=q(j,i,t)
        end do
     end do
!!$        !* Enforce cell center Boundary Nodes for time loops*!
        Do j=1,3
           q(j,1,t+1)=q(j,1,0)
           q(j,NI,t+1)=q(j,NI-1,t)
        End do
        !Update Face at new time level
        do i=1,NV
           qf(1,i,t+1)=0.5*(q(1,i,t+1)+q(1,i+1,t+1))
           qf(2,i,t+1)=0.5*(q(2,i,t+1)+q(2,i+1,t+1))
           qf(3,i,t+1)=0.5*(q(3,i,t+1)+q(3,i+1,t+1))
        end do
        !Enforce BC on the Face!
!!$        Do j=1,3
!!$           qf(j,1,t+1)=qf(j,1,0)
!!$           qf(j,NV,t+1)=qf(j,NV-1,t+1)
!!$        End do

  !*End Timestep*!
  End do

write(6,*) 'End Euler Scheme'
!!----------------------------End Euler Scheme----------------------------------------

write(*,*) 'L2norm(1,t)'
do t=1,NT
   write(*,*) t, L2norm(1,t)
end do
write(*,*)

write(*,*)

write(6,*) 'Replace q terms with velocity and pressure'
!*Replace q's with velocity and pressure*!
do i=1,NI
   !*Velocity*!
   q(2,i,NT)=q(2,i,NT)/q(1,i,NT)
   !*Pressure*!
   q(3,i,NT)=(gamma-1.0)*q(3,i,NT) - 0.5*(gamma-1.0)*(q(2,i,t)**2)/q(1,i,t)
end do

write(*,*) 'L2norm(5,m)'
do m=1,15
   write(*,*) newtonL2norm(0,m)
end do
write(*,*)
write(*,*) 'L2norm(10,m)'
do m=1,15
   write(*,*) newtonL2norm(10,m)
end do
write(*,*)
write(*,*) 'L2norm(15,m)'
do m=1,15
   write(*,*) newtonL2norm(20,m)
end do
write(*,*)
write(*,*) 'L2norm(40,m)'
do m=1,15
   write(*,*) newtonL2norm(50,m)
end do
write(*,*)
write(*,*) 'L2norm(NT,m)'
do m=1,15
   write(*,*) newtonL2norm(NT,m)
end do
write(*,*)

write(6,*) 'Write outputs'

  write(6,*) 'Write x,q1'
  ! output Gnuplot file-------------------------Solution---------------------------
  OPEN(UNIT=1, FILE='q1.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  DO i=1, NI
     WRITE(UNIT=1,FMT='(E19.10," ",E19.10)') x(i),q(1,i,NT)
  End do
  WRITE(UNIT=1,FMT='(" ")')
  !Do i=1,NI
  !   WRITE(UNIT=1,FMT='(E19.10," ",E19.10)') x(i)+dt*Nt*0.5*(1.5+.5),Uexact(i,40)
  !End do
  CLOSE(UNIT=1)

  write(6,*) 'Write x,q2'
  ! output Gnuplot file-------------------------Solution---------------------------
  OPEN(UNIT=3, FILE='q2.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  DO i=1, NI
     WRITE(UNIT=3,FMT='(E19.10," ",E19.10)') x(i),q(2,i,NT)
  End do
  WRITE(UNIT=3,FMT='(" ")')
!  Do i=1,NI
!     WRITE(UNIT=3,FMT='(E19.10," ",E19.10)') x(i)+dt*Nt*0.5*(1.5+.5),Uexact(i,40)
!  End do
  CLOSE(UNIT=3)

  write(6,*) 'Write x,q3'
  ! output Gnuplot file-------------------------Solution---------------------------
  OPEN(UNIT=4, FILE='q3.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  DO i=1, NI
     WRITE(UNIT=4,FMT='(E19.10," ",E19.10)') x(i),q(3,i,NT)
  End do
  WRITE(UNIT=4,FMT='(" ")')
!  Do i=1,NI
!     WRITE(UNIT=4,FMT='(E19.10," ",E19.10)') x(i)+dt*Nt*0.5*(1.5+.5),Uexact(i,40)
!  End do
  CLOSE(UNIT=4)

  write(6,*) 'Write t,L2norm'
!!-------------------------------------------------------L2NORM----------------------
  ! output Gnuplot file
  OPEN(UNIT=2, FILE='L2norm.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  Do t=1,nt
     WRITE(UNIT=2,FMT='(I5,"",E19.10)') t, L2norm(1,t)
  End do
  WRITE(UNIT=2,FMT='(" ")')
  CLOSE(UNIT=2)

  write(6,*) 'Write x,r'
  ! output Gnuplot file-------------------------Solution---------------------------
  OPEN(UNIT=5, FILE='r.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
     DO i=1, NV
        WRITE(UNIT=5,FMT='(E19.10," ",E19.10)') x(i),r(i)
     End do
     WRITE(UNIT=5,FMT='(" ")')
!  Do i=1,NI
!     WRITE(UNIT=4,FMT='(E19.10," ",E19.10)') x(i)+dt*Nt*0.5*(1.5+.5),Uexact(i,40)
!  End do
  CLOSE(UNIT=5)

!   write(6,*) 'Write it1(t),newtonL2norm'
! !!-------------------------------------------------------L2NORM----------------------
!   ! output Gnuplot file
!   OPEN(UNIT=6, FILE='newtonL2norm.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
!   !Do t=3,5
!      DO m=1,14
!         !WRITE(UNIT=6,FMT='(I5," ",E19.10)') m,newtonL2norm(it1(t),m)
!         WRITE(UNIT=6,FMT='(I5," ",E19.10)') m,newtonL2norm(10,m)
!      END DO
!      WRITE(UNIT=6,FMT='(" ")')

!      DO m=1,14
!       WRITE(UNIT=6,FMT='(I5," ",E19.10)') m,newtonL2norm(15,m)
!    END DO
!    WRITE(UNIT=6,FMT='(" ")')

!    DO m=1,14
!       WRITE(UNIT=6,FMT='(I5," ",E19.10)') m,newtonL2norm(40,m)
!    END DO
!    WRITE(UNIT=6,FMT='(" ")')

!   !End do
!   WRITE(UNIT=6,FMT='(" ")')
!   CLOSE(UNIT=6)

!   write(6,*) 'Write it1(t),newtonL2norm, Done'

!! Plotting in gnu plot
!! once in the proper directory in terminal, open a second tab
!! type:  gnuplot   to open gnuplot
!! type:  plot "Gnu.dat" w l        to plot

  write(6,*) 'deallocating'

  write(6,*) 'deallocating X'
  IF (ALLOCATED(X)) DEALLOCATE(X)
  !IF (ALLOCATED(U)) DEALLOCATE(U)
  !IF (ALLOCATED(Unm)) DEALLOCATE(Unm)
  !IF (ALLOCATED(Uexact)) DEALLOCATE(Uexact)

  write(6,*) 'deallocating q'
  IF (ALLOCATED(Q)) DEALLOCATE(Q)
  write(6,*) 'deallocating qf'
  IF (ALLOCATED(Qf)) DEALLOCATE(Qf)
  write(6,*) 'deallocating qc'
  IF (ALLOCATED(qc)) DEALLOCATE(qc)

  write(6,*) 'deallocating f'
  IF (ALLOCATED(f)) DEALLOCATE(f)
  write(6,*) 'deallocating h'
  IF (ALLOCATED(h)) DEALLOCATE(h)

  write(6,*) 'deallocating deltaQ'
  !IF (ALLOCATED(Fplus)) DEALLOCATE(Fplus)
  !IF (ALLOCATED(Fminus)) DEALLOCATE(Fminus)
  IF (ALLOCATED(deltaQ)) DEALLOCATE(deltaQ)

  write(6,*) 'deallocating RHS'
  IF (ALLOCATED(RHS)) DEALLOCATE(RHS)

  write(6,*) 'deallocating dfdq, dhdq'
  IF (ALLOCATED(dfdq)) DEALLOCATE(dfdq)
  IF (ALLOCATED(dhdq)) DEALLOCATE(dhdq)

  write(6,*) 'deallocating 5'
!!$  IF (ALLOCATED(rface)) DEALLOCATE(rface)
!!$  IF (ALLOCATED(Sface)) DEALLOCATE(Sface)
  IF (ALLOCATED(r)) DEALLOCATE(r)
  IF (ALLOCATED(S)) DEALLOCATE(S)
  IF (ALLOCATED(Vol)) DEALLOCATE(Vol)
  IF (ALLOCATED(deltaS)) DEALLOCATE(deltaS)
  IF (ALLOCATED(deltaVol)) DEALLOCATE(deltaVol)

  write(6,*) 'deallocating p'
  IF (ALLOCATED(p)) DEALLOCATE(p)

  write(6,*) 'deallocating am, bm, cm'
  IF (ALLOCATED(am)) DEALLOCATE(am)
  IF (ALLOCATED(bm)) DEALLOCATE(bm)
  IF (ALLOCATED(cm)) DEALLOCATE(cm)

  write(6,*) 'deallocating L2'
  !IF (ALLOCATED(L1)) DEALLOCATE(L1)
  IF (ALLOCATED(L2)) DEALLOCATE(L2)
  !IF (ALLOCATED(Aplus)) DEALLOCATE(Aplus)
  !IF (ALLOCATED(Aminus)) DEALLOCATE(Aminus)

  !IF (ALLOCATED(Delta)) DEALLOCATE(Delta)

  write(6,*) 'deallocating L2norm'
  IF (ALLOCATED(L2norm)) DEALLOCATE(L2norm)
  IF (ALLOCATED(newtonL2norm)) DEALLOCATE(newtonL2norm)

  write(6,*) 'deallocating 4'
  IF (ALLOCATED(vU)) DEALLOCATE(vU)
  IF (ALLOCATED(V)) DEALLOCATE(V)

END PROGRAM solver


!----------------------------------------------------------------------
! Module: module_apply_convol.f90
!> Purpose: convolution routines
!>

!> Author: Benjamin Menetrier
!>

!> Licensing: this code is distributed under the CeCILL-C license
!>

!> Copyright © 2017 METEO-FRANCE
!----------------------------------------------------------------------
module module_apply_convol

use module_apply_com, only: alpha_com_AB,alpha_com_BA,alpha_com_CA,alpha_copy_AC,alpha_copy_BC
use module_namelist, only: nproc
use omp_lib
use tools_missing, only: msr
use type_fields, only: alphatype
use type_linop, only: apply_linop_sym
use type_mpl, only: mpl
use type_sdata, only: sdatatype,sdatampitype
implicit none

private
public :: convol

contains

!----------------------------------------------------------------------
! Subroutine: convol
!> Purpose: convolution
!----------------------------------------------------------------------
subroutine convol(sdata,alpha)

implicit none

! Passed variables
type(sdatatype),intent(in) :: sdata                 !< Sampling data
type(alphatype),intent(inout) :: alpha(sdata%nproc) !< Subgrid variable

! Local variables
integer :: iproc

if (nproc==0) then
   ! Apply global convolution
   call convol_global(sdata,alpha(1))
elseif (nproc>0) then
   ! Communication
   if (sdata%mpicom==1) then
      ! Copy zone B into zone C
      do iproc=1,sdata%nproc
         call alpha_copy_BC(sdata%mpi(iproc),alpha(iproc))
      end do
   elseif (sdata%mpicom==2) then
      ! Halo reduction from zone B to zone A
      call alpha_com_BA(sdata,alpha)

      ! Copy zone A into zone C
      do iproc=1,sdata%nproc
         call alpha_copy_AC(sdata%mpi(iproc),alpha(iproc))
      end do
   end if

   ! Apply local convolution
   do iproc=1,sdata%nproc
      call convol_local(sdata%mpi(iproc),alpha(iproc))
   end do
end if

! Communication
if (nproc>0) then
   ! Halo reduction from zone C to zone A
   call alpha_com_CA(sdata,alpha)

   ! Halo extension from zone A to zone B
   call alpha_com_AB(sdata,alpha)
end if

end subroutine convol

!----------------------------------------------------------------------
! Subroutine: convol_global
!> Purpose: convolution, global
!----------------------------------------------------------------------
subroutine convol_global(sdata,alpha)

implicit none

! Passed variables
type(sdatatype),intent(in) :: sdata    !< Sampling data
type(alphatype),intent(inout) :: alpha !< Subgrid variable

! Apply linear operator, symmetric
call apply_linop_sym(sdata%c,alpha%val)

end subroutine convol_global

!----------------------------------------------------------------------
! Subroutine: convol_local
!> Purpose: convolution, local
!----------------------------------------------------------------------
subroutine convol_local(sdatampi,alpha)

implicit none

! Passed variables
type(sdatampitype),intent(in) :: sdatampi !< Sampling data
type(alphatype),intent(inout) :: alpha    !< Subgrid variable

! Apply linear operator, symmetric
call apply_linop_sym(sdatampi%c,alpha%valc)

end subroutine convol_local

end module module_apply_convol


! Test eoshift2 for character arrays.
! { dg-do run }
program main
  implicit none
  integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3
  character (len = slen), dimension (n1, n2, n3) :: a
  character (len = slen), dimension (n1, n3) :: filler
  integer (kind = 1) :: shift1 = 4
  integer (kind = 2) :: shift2 = 2
  integer (kind = 4) :: shift3 = 3
  integer (kind = 8) :: shift4 = 1
  integer :: i1, i2, i3

  filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /)
  filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /)

  do i3 = 1, n3
    do i2 = 1, n2
      do i1 = 1, n1
        a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3)
      end do
    end do
  end do

  call test (eoshift (a, shift1, filler, 2), int (shift1), .true.)
  call test (eoshift (a, shift2, filler, 2), int (shift2), .true.)
  call test (eoshift (a, shift3, filler, 2), int (shift3), .true.)
  call test (eoshift (a, shift4, filler, 2), int (shift4), .true.)

  call test (eoshift (a, shift1, dim = 2), int (shift1), .false.)
  call test (eoshift (a, shift2, dim = 2), int (shift2), .false.)
  call test (eoshift (a, shift3, dim = 2), int (shift3), .false.)
  call test (eoshift (a, shift4, dim = 2), int (shift4), .false.)
contains
  subroutine test (b, d2, has_filler)
    character (len = slen), dimension (n1, n2, n3) :: b
    logical :: has_filler
    integer :: d2

    do i3 = 1, n3
      do i2 = 1, n2
        do i1 = 1, n1
          if (i2 + d2 .le. n2) then
            if (b (i1, i2, i3) .ne. a (i1, i2 + d2, i3)) call abort
          else if (has_filler) then
            if (b (i1, i2, i3) .ne. filler (i1, i3)) call abort
          else
            if (b (i1, i2, i3) .ne. '') call abort
          end if
        end do
      end do
    end do
  end subroutine test
end program main


module matrix
  implicit none

contains

  function row(m, m_dim, i) result(r)
    character(len=*), dimension(:) :: m
    integer, intent(in) :: m_dim(2)
    integer, intent(in) :: i
    integer :: r(m_dim(1))
    integer :: A(m_dim(1),m_dim(2))
    call read_m(m,m_dim, A)
    r(:) = A(:,i)
  end function

  function column(m, m_dim, j) result(c)
    character(len=*), dimension(:) :: m
    integer, intent(in) :: m_dim(2)
    integer, intent(in) :: j
    integer :: c(m_dim(2))
    integer :: A(m_dim(1),m_dim(2))
    call read_m(m,m_dim, A)
    c(:) = A(j,:)
  end function

  subroutine read_m(m,m_dim, A)
    character(len=*), dimension(:) :: m
    integer, intent(in) :: m_dim(2)
    integer :: A(m_dim(1),m_dim(2))
    integer :: i

    do i=1,m_dim(2)
      read(m(i),*) A(:,i)
    enddo

  end subroutine

end module


	SUBROUTINE TI_DIFF  ( dattm1, dattm2, nmin, iret )
C************************************************************************
C* TI_DIFF								*
C*									*
C* This subroutine computes the time difference in minutes between 	*
C* two standard GEMPAK times.  The time difference is time1 - time2	*
C* and may be computed for a maximum of one year.			*
C*									*
C* TI_DIFF  ( DATTM1, DATTM2, NMIN, IRET )				*
C*									*
C* Input parameters:							*
C*	DATTM1		CHAR*		First GEMPAK time		*
C*	DATTM2		CHAR*		Second GEMPAK time		*
C*									*
C* Output parameters:							*
C*	NMIN		INTEGER		Difference in minutes		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*				  	-12 = invalid time range	*
C**									*
C* Log:									*
C* M. Goodman/RDS	12/85						*
C* M. desJardins/GSFC	11/87	GEMPAK 4				*
C************************************************************************
	CHARACTER*(*)	dattm1, dattm2
C*
	INTEGER		idtar1 (5), idtar2 (5)
C------------------------------------------------------------------------
	iret = 0
	nmin = 0
C
C*	Convert GEMPAK times to integers.
C
	CALL TI_CTOI  ( dattm1, idtar1, iret )
	IF  ( iret .ne. 0 )  RETURN
C*
	CALL TI_CTOI  ( dattm2, idtar2, iret )
	IF  ( iret .ne. 0 )  RETURN
C
C*	Call subroutine to do calculation with integer variables.
C
	CALL TI_MDIF  ( idtar1, idtar2, nmin, iret )
C*
	RETURN
	END


module test_projection_module

  use bl_types
  use bl_constants_module
  use multifab_module
  use ml_cc_restriction_module
  use ml_layout_module
  use define_bc_module
  use multifab_fill_ghost_module
  use multifab_physbc_module

  implicit none

  private
  public :: init_velocity, init_mac_velocity, &
       add_grad_scalar, add_grad_scalar_mac, convert_MAC_to_cc

contains

  !===========================================================================
  subroutine init_velocity(U, dx, mla, the_bc_level)

    integer :: n, i, ng, dm, nlevs

    type(multifab) , intent(inout) :: U(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:)
    type(ml_layout)   , intent(inout) :: mla
    type(bc_level)    , intent(in   ) :: the_bc_level(:)

    integer :: lo(get_dim(U(1))), hi(get_dim(U(1)))

    real(kind=dp_t), pointer :: up(:,:,:,:)

    nlevs = size(U)
    dm = get_dim(U(1))

    ng = nghost(U(1))

    do n=1,nlevs
       do i = 1, nfabs(U(n))
          up => dataptr(U(n), i)
          lo = lwb(get_box(U(n), i))
          hi = upb(get_box(U(n), i))

          select case (dm)
          case (2)
             call init_velocity_2d(up(:,:,1,:), ng, lo, hi, dx(n,:))

          case (3)
             call init_velocity_3d(up(:,:,:,:), ng, lo, hi, dx(n,:))

          end select
       end do
    end do

    ! fill ghostcells
    if (nlevs .eq. 1) then

       ! fill ghost cells for two adjacent grids at the same level
       ! this includes periodic domain boundary ghost cells
       call multifab_fill_boundary(U(nlevs))

       ! fill non-periodic domain boundary ghost cells
       call multifab_physbc(U(nlevs),1,1,dm,the_bc_level(nlevs))

    else

       ! the loop over nlevs must count backwards to make sure the
       ! finer grids are done first
       do n=nlevs,2,-1

          ! set level n-1 data to be the average of the level n
          ! data covering it
          call ml_cc_restriction(U(n-1),U(n),mla%mba%rr(n-1,:))

          ! fill level n ghost cells using interpolation from
          ! level n-1 data note that multifab_fill_boundary and
          ! multifab_physbc are called for both levels n-1 and n
          call multifab_fill_ghost_cells(U(n),U(n-1),nghost(U(n)), &
                                         mla%mba%rr(n-1,:), &
                                         the_bc_level(n-1), &
                                         the_bc_level(n), &
                                         1,1,dm)

       enddo

    end if

  end subroutine init_velocity

  subroutine init_velocity_2d(U, ng, lo, hi, dx)

    ! initialize the velocity field to a divergence-free field.  This
    ! velocity field comes from Almgren, Bell, and Szymczak 1996.

    use probin_module, only: prob_lo

    integer         , intent(in   ) :: lo(:), hi(:), ng
    real (kind=dp_t), intent(inout) :: U(lo(1)-ng:,lo(2)-ng:,:)
    real (kind=dp_t), intent(in   ) :: dx(:)

    ! Local variables
    integer :: i, j
    real (kind=dp_t) :: x, y

    do j = lo(2), hi(2)
       y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

       do i = lo(1), hi(1)
          x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

          U(i,j,1) = -sin(M_PI*x)**2 * sin(TWO*M_PI*y)
          U(i,j,2) =  sin(M_PI*y)**2 * sin(TWO*M_PI*x)

       enddo
    enddo

  end subroutine init_velocity_2d

  subroutine init_velocity_3d(U, ng, lo, hi, dx)

    ! initialize the velocity field to a divergence-free field.  This
    ! velocity field comes from the idea that the curl of any vector
    ! is divergence-free.
    !
    ! we take: Phi = (alpha, beta, gamma) as our initial vector, with:
    !
    !   alpha = sin 4pi y  sin 2pi z
    !   beta  = sin 2pi x  sin 4pi z
    !   gamma = sin 4pi x  sin 2pi y
    !
    ! (this is periodic and even in all directions)
    !
    ! then U = curl{Phi} gives our field

    use probin_module, only: prob_lo

    integer         , intent(in   ) :: lo(:), hi(:), ng
    real (kind=dp_t), intent(inout) :: U(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:,:)
    real (kind=dp_t), intent(in   ) :: dx(:)

    ! Local variables
    integer :: i, j, k
    real (kind=dp_t) :: x, y, z

    do k = lo(3), hi(3)
       z = (dble(k)+0.5d0)*dx(3) + prob_lo(3)

       do j = lo(2), hi(2)
          y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)
             x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

             U(i,j,k,1) = TWO*M_PI*sin(FOUR*M_PI*x)*cos( TWO*M_PI*y) - &
                         FOUR*M_PI*sin( TWO*M_PI*x)*cos(FOUR*M_PI*z)

             U(i,j,k,2) = TWO*M_PI*sin(FOUR*M_PI*y)*cos( TWO*M_PI*z) - &
                         FOUR*M_PI*cos(FOUR*M_PI*x)*sin( TWO*M_PI*y)

             U(i,j,k,3) = TWO*M_PI*cos( TWO*M_PI*x)*sin(FOUR*M_PI*z) - &
                         FOUR*M_PI*cos(FOUR*M_PI*y)*sin( TWO*M_PI*z)

          enddo
       enddo
    enddo

  end subroutine init_velocity_3d

  !===========================================================================
  subroutine init_mac_velocity(umac, dx, mla, the_bc_level)

    integer :: n, i, ng, dm, nlevs

    type(multifab) , intent(inout) :: umac(:,:)
    real(kind=dp_t), intent(in   ) :: dx(:,:)
    type(ml_layout)   , intent(inout) :: mla
    type(bc_level)    , intent(in   ) :: the_bc_level(:)

    integer :: lo(get_dim(umac(1,1))), hi(get_dim(umac(1,1)))

    real(kind=dp_t), pointer :: ump(:,:,:,:), vmp(:,:,:,:), wmp(:,:,:,:)

    nlevs = size(umac(:,1))
    dm = get_dim(umac(1,1))

    ng = nghost(umac(1,1))

    do n=1,nlevs
       do i = 1, nfabs(umac(n,1))
          ump => dataptr(umac(n,1), i)
          vmp => dataptr(umac(n,2), i)

          lo = lwb(get_box(umac(n,1), i))
          hi = upb(get_box(umac(n,1), i))

          select case (dm)
          case (2)
             call init_mac_velocity_2d(ump(:,:,1,1), vmp(:,:,1,1), ng, &
                                       lo, hi, dx(n,:))

          case (3)
             wmp => dataptr(umac(n,3), i)
             call init_mac_velocity_3d(ump(:,:,:,1), vmp(:,:,:,1), wmp(:,:,:,1), ng, &
                                       lo, hi, dx(n,:))

          end select
       end do
    end do

    ! make edge states consistent across levels
    do n = nlevs,2,-1
       do i = 1, dm
          call ml_edge_restriction_c(umac(n-1,i),1,umac(n,i),1,mla%mba%rr(n-1,:),i,1)
       enddo
    enddo

  end subroutine init_mac_velocity

  subroutine init_mac_velocity_2d(umac, vmac, ng, lo, hi, dx)

    ! initialize the velocity field to a divergence-free field.  This
    ! velocity field comes from Almgren, Bell, and Szymczak 1996.

    use probin_module, only: prob_lo

    integer         , intent(in   ) :: lo(:), hi(:), ng
    real (kind=dp_t), intent(inout) :: umac(lo(1)-ng:,lo(2)-ng:)
    real (kind=dp_t), intent(inout) :: vmac(lo(1)-ng:,lo(2)-ng:)
    real (kind=dp_t), intent(in   ) :: dx(:)

    ! Local variables
    integer :: i, j
    real (kind=dp_t) :: x, y

    ! x-velocity  (x are edges, y are centers)
    do j = lo(2), hi(2)
       y = (dble(j)+HALF)*dx(2) + prob_lo(2)

       do i = lo(1), hi(1)+1
          x = (dble(i))*dx(1) + prob_lo(1)

          umac(i,j) = -sin(M_PI*x)**2 * sin(TWO*M_PI*y)

       enddo
    enddo

    ! y-velocity  (x are centers, y are edges)
    do j = lo(2), hi(2)+1
       y = (dble(j))*dx(2) + prob_lo(2)

       do i = lo(1), hi(1)
          x = (dble(i)+HALF)*dx(1) + prob_lo(1)

          vmac(i,j) =  sin(M_PI*y)**2 * sin(TWO*M_PI*x)

       enddo
    enddo

  end subroutine init_mac_velocity_2d

  subroutine init_mac_velocity_3d(umac, vmac, wmac, ng, lo, hi, dx)

    ! initialize the velocity field to a divergence-free field.  This
    ! velocity field comes from the idea that the curl of any vector
    ! is divergence-free.
    !
    ! we take: Phi = (alpha, beta, gamma) as our initial vector, with:
    !
    !   alpha = sin 4pi y  sin 2pi z
    !   beta  = sin 2pi x  sin 4pi z
    !   gamma = sin 4pi x  sin 2pi y
    !
    ! (this is periodic and even in all directions)
    !
    ! then U = curl{Phi} gives our field

    use probin_module, only: prob_lo

    integer         , intent(in   ) :: lo(:), hi(:), ng
    real (kind=dp_t), intent(inout) :: umac(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    real (kind=dp_t), intent(inout) :: vmac(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    real (kind=dp_t), intent(inout) :: wmac(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    real (kind=dp_t), intent(in   ) :: dx(:)

    ! Local variables
    integer :: i, j, k
    real (kind=dp_t) :: x, y, z

    ! x-velocity  (x are edges, y and z are centers)
    do k = lo(3), hi(3)
       z = (dble(k)+HALF)*dx(3) + prob_lo(3)

       do j = lo(2), hi(2)
          y = (dble(j)+HALF)*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)+1
             x = (dble(i))*dx(1) + prob_lo(1)

             umac(i,j,k) = TWO*M_PI*sin(FOUR*M_PI*x)*cos( TWO*M_PI*y) - &
                          FOUR*M_PI*sin( TWO*M_PI*x)*cos(FOUR*M_PI*z)

          enddo
       enddo
    enddo

    ! y-velocity  (x and z are centers, y are edges)
    do k = lo(3), hi(3)
       z = (dble(k)+HALF)*dx(3) + prob_lo(3)

       do j = lo(2), hi(2)+1
          y = (dble(j))*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)
             x = (dble(i)+HALF)*dx(1) + prob_lo(1)

             vmac(i,j,k) = TWO*M_PI*sin(FOUR*M_PI*y)*cos( TWO*M_PI*z) - &
                          FOUR*M_PI*cos(FOUR*M_PI*x)*sin( TWO*M_PI*y)

          enddo
       enddo
    enddo

    ! z-velocity  (x and y are centers, z are edges)
    do k = lo(3), hi(3)+1
       z = (dble(k))*dx(3) + prob_lo(3)

       do j = lo(2), hi(2)
          y = (dble(j)+HALF)*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)
             x = (dble(i)+HALF)*dx(1) + prob_lo(1)

             wmac(i,j,k) = TWO*M_PI*cos( TWO*M_PI*x)*sin(FOUR*M_PI*z) - &
                          FOUR*M_PI*cos(FOUR*M_PI*y)*sin( TWO*M_PI*z)

          enddo
       enddo
    enddo

  end subroutine init_mac_velocity_3d

  !===========================================================================
  subroutine add_grad_scalar(U, gphi, dx, mla, the_bc_level)

    integer :: n, i, ng, dm, nlevs

    type(multifab) , intent(inout) :: U(:)
    type(multifab) , intent(inout) :: gphi(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:)
    type(ml_layout)   , intent(inout) :: mla
    type(bc_level)    , intent(in   ) :: the_bc_level(:)

    integer :: lo(get_dim(U(1))), hi(get_dim(U(1)))

    real(kind=dp_t), pointer :: up(:,:,:,:)
    real(kind=dp_t), pointer :: gp(:,:,:,:)

    nlevs = size(U)
    dm = get_dim(U(1))

    ng = nghost(U(1))

    do n=1,nlevs
       do i = 1, nfabs(U(n))
          up => dataptr(U(n), i)
          gp => dataptr(gphi(n), i)
          lo = lwb(get_box(U(n), i))
          hi = upb(get_box(U(n), i))

          select case (dm)
          case (2)
             call add_grad_scalar_2d(up(:,:,1,:), gp(:,:,1,:), ng, lo, hi, dx(n,:), &
                                     the_bc_level(n)%phys_bc_level_array(0,:,:), &
                                     the_bc_level(n)%phys_bc_level_array(i,:,:))

          case (3)
             call add_grad_scalar_3d(up(:,:,:,:), gp(:,:,:,:), ng, lo, hi, dx(n,:), &
                                     the_bc_level(n)%phys_bc_level_array(0,:,:), &
                                     the_bc_level(n)%phys_bc_level_array(i,:,:))

          end select
       end do
    end do

    ! fill ghostcells
    if (nlevs .eq. 1) then

       ! fill ghost cells for two adjacent grids at the same level
       ! this includes periodic domain boundary ghost cells
       call multifab_fill_boundary(U(nlevs))

       ! fill non-periodic domain boundary ghost cells
       call multifab_physbc(U(nlevs),1,1,dm,the_bc_level(nlevs))

    else

       ! the loop over nlevs must count backwards to make sure the
       ! finer grids are done first
       do n=nlevs,2,-1

          ! set level n-1 data to be the average of the level n
          ! data covering it
          call ml_cc_restriction(U(n-1),U(n),mla%mba%rr(n-1,:))

          ! fill level n ghost cells using interpolation from
          ! level n-1 data note that multifab_fill_boundary and
          ! multifab_physbc are called for both levels n-1 and n
          call multifab_fill_ghost_cells(U(n),U(n-1),nghost(U(n)), &
                                         mla%mba%rr(n-1,:), &
                                         the_bc_level(n-1), &
                                         the_bc_level(n), &
                                         1,1,dm)

       enddo

    end if

  end subroutine add_grad_scalar

  subroutine add_grad_scalar_2d(U, gphi, ng, lo, hi, dx, &
                                domain_phys_bc, box_phys_bc)

    use     bc_module
    use probin_module, only: prob_lo

    integer         , intent(in   ) :: lo(:), hi(:), ng
    real (kind=dp_t), intent(inout) ::    U(lo(1)-ng:,lo(2)-ng:,:)
    real (kind=dp_t), intent(inout) :: gphi(lo(1)-ng:,lo(2)-ng:,:)
    real (kind=dp_t), intent(in   ) :: dx(:)
    integer         , intent(in   ) :: domain_phys_bc(:,:)
    integer         , intent(in   ) :: box_phys_bc(:,:)

    ! Local variables
    integer :: i, j
    real (kind=dp_t) :: x, y
    real (kind=dp_t), allocatable :: phi(:,:)

    allocate(phi(lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1))

    if (domain_phys_bc(1,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(1,2) .eq. SLIP_WALL .and. &
        domain_phys_bc(2,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(2,2) .eq. SLIP_WALL) then

       ! Add on the gradient of a scalar (phi) that satisfies
       ! grad(phi).n = 0.
       do j = lo(2), hi(2)
          y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)
             x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

             gphi(i,j,1) =  FOUR*x*(ONE - x)
             gphi(i,j,2) =  FOUR*y*(ONE - y)

             U(i,j,1) = U(i,j,1) + gphi(i,j,1)
             U(i,j,2) = U(i,j,2) + gphi(i,j,2)

          enddo
       enddo

    else if (domain_phys_bc(1,1) .eq. PERIODIC .and. &
             domain_phys_bc(1,2) .eq. PERIODIC .and. &
             domain_phys_bc(2,1) .eq. PERIODIC .and. &
             domain_phys_bc(2,2) .eq. PERIODIC) then

       do j = lo(2)-1, hi(2)+1
          y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

          do i = lo(1)-1, hi(1)+1
             x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

               phi(i,j) = 0.1d0 * cos(2.d0*M_PI*y)*cos(2.d0*M_PI*x)

          enddo
       enddo

       do j = lo(2), hi(2)
          y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)
             x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

             gphi(i,j,1) =  (phi(i+1,j)-phi(i-1,j))/(2.d0*dx(1))
             gphi(i,j,2) =  (phi(i,j+1)-phi(i,j-1))/(2.d0*dx(2))

             U(i,j,1) = U(i,j,1) + gphi(i,j,1)
             U(i,j,2) = U(i,j,2) + gphi(i,j,2)

          enddo
       enddo

    else
       call bl_error('Not set up for these boundary conditions')
    end if

    deallocate(phi)

  end subroutine add_grad_scalar_2d

  subroutine add_grad_scalar_3d(U, gphi, ng, lo, hi, dx, &
                                domain_phys_bc, box_phys_bc)

    use     bc_module
    use probin_module, only: prob_lo

    integer         , intent(in   ) :: lo(:), hi(:), ng
    real (kind=dp_t), intent(inout) ::    U(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:,:)
    real (kind=dp_t), intent(inout) :: gphi(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:,:)
    real (kind=dp_t), intent(in   ) :: dx(:)
    integer         , intent(in   ) :: domain_phys_bc(:,:)
    integer         , intent(in   ) :: box_phys_bc(:,:)

    ! Local variables
    integer :: i, j, k
    real (kind=dp_t) :: x, y, z
    real (kind=dp_t), allocatable :: phi(:,:,:)

    allocate(phi(lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1,lo(3)-1:hi(3)+1))

    if (domain_phys_bc(1,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(1,2) .eq. SLIP_WALL .and. &
        domain_phys_bc(2,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(2,2) .eq. SLIP_WALL .and. &
        domain_phys_bc(3,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(3,2) .eq. SLIP_WALL) then

       ! Add on the gradient of a scalar (phi) that satisfies
       ! grad(phi).n = 0.
       do k = lo(3), hi(3)
          z = (dble(k)+0.5d0)*dx(3) + prob_lo(3)

          do j = lo(2), hi(2)
             y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

             do i = lo(1), hi(1)
                x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

                gphi(i,j,k,1) =  160.0_dp_t*x*(ONE - x)
                gphi(i,j,k,2) =  160.0_dp_t*y*(ONE - y)
                gphi(i,j,k,3) =  160.0_dp_t*z*(ONE - z)

                U(i,j,k,1) = U(i,j,k,1) + gphi(i,j,k,1)
                U(i,j,k,2) = U(i,j,k,2) + gphi(i,j,k,2)
                U(i,j,k,3) = U(i,j,k,3) + gphi(i,j,k,3)

             enddo
          enddo
       enddo

    else if (domain_phys_bc(1,1) .eq. PERIODIC .and. &
             domain_phys_bc(1,2) .eq. PERIODIC .and. &
             domain_phys_bc(2,1) .eq. PERIODIC .and. &
             domain_phys_bc(2,2) .eq. PERIODIC .and. &
             domain_phys_bc(3,1) .eq. PERIODIC .and. &
             domain_phys_bc(3,2) .eq. PERIODIC) then

       do k = lo(3)-1, hi(3)+1
          z = (dble(k)+0.5d0)*dx(3) + prob_lo(3)

          do j = lo(2)-1, hi(2)+1
             y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

             do i = lo(1)-1, hi(1)+1
                x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

                phi(i,j,k) = 5.0d0 * cos(2.d0*M_PI*y)*cos(2.d0*M_PI*x)*cos(2.d0*M_PI*z)

             enddo
          enddo
       enddo

       do k = lo(3), hi(3)
          z = (dble(k)+0.5d0)*dx(3) + prob_lo(3)

          do j = lo(2), hi(2)
             y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

             do i = lo(1), hi(1)
                x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

                gphi(i,j,k,1) =  (phi(i+1,j,k)-phi(i-1,j,k))/(2.d0*dx(1))
                gphi(i,j,k,2) =  (phi(i,j+1,k)-phi(i,j-1,k))/(2.d0*dx(2))
                gphi(i,j,k,3) =  (phi(i,j,k+1)-phi(i,j,k-1))/(2.d0*dx(3))

                U(i,j,k,1) = U(i,j,k,1) + gphi(i,j,k,1)
                U(i,j,k,2) = U(i,j,k,2) + gphi(i,j,k,2)
                U(i,j,k,3) = U(i,j,k,3) + gphi(i,j,k,3)

             enddo
          enddo
       enddo

    else
       call bl_error('Not set up for these boundary conditions')
    end if

    deallocate(phi)

  end subroutine add_grad_scalar_3d

  !===========================================================================
  subroutine add_grad_scalar_mac(umac, gphi_mac, dx, mla, the_bc_level)

    type(multifab) , intent(inout) :: umac(:,:)
    type(multifab) , intent(inout) :: gphi_mac(:,:)
    real(kind=dp_t), intent(in   ) :: dx(:,:)
    type(ml_layout)   , intent(inout) :: mla
    type(bc_level)    , intent(in   ) :: the_bc_level(:)

    integer :: n, i, ng_um, ng_gp, dm, nlevs

    integer :: lo(get_dim(umac(1,1))), hi(get_dim(umac(1,1)))

    real(kind=dp_t), pointer :: ump(:,:,:,:)
    real(kind=dp_t), pointer :: vmp(:,:,:,:)
    real(kind=dp_t), pointer :: wmp(:,:,:,:)

    real(kind=dp_t), pointer :: gxp(:,:,:,:)
    real(kind=dp_t), pointer :: gyp(:,:,:,:)
    real(kind=dp_t), pointer :: gzp(:,:,:,:)

    nlevs = size(umac(:,1))
    dm = get_dim(umac(1,1))

    ng_um = nghost(umac(1,1))
    ng_gp = nghost(gphi_mac(1,1))

    do n=1,nlevs
       do i = 1, nfabs(umac(n,1))
          ump => dataptr(umac(n,1), i)
          vmp => dataptr(umac(n,2), i)

          gxp => dataptr(gphi_mac(n,1), i)
          gyp => dataptr(gphi_mac(n,2), i)

          lo = lwb(get_box(umac(n,1), i))
          hi = upb(get_box(umac(n,1), i))

          select case (dm)
          case (2)
             call add_grad_scalar_2d_mac(ump(:,:,1,1), vmp(:,:,1,1), ng_um, &
                                         gxp(:,:,1,1), gyp(:,:,1,1), ng_gp, &
                                         lo, hi, dx(n,:), &
                                         the_bc_level(n)%phys_bc_level_array(0,:,:), &
                                         the_bc_level(n)%phys_bc_level_array(i,:,:))

          case (3)
             wmp => dataptr(umac(n,3), i)
             gzp => dataptr(gphi_mac(n,3), i)
             call add_grad_scalar_3d_mac(ump(:,:,:,1), vmp(:,:,:,1), wmp(:,:,:,1), ng_um, &
                                         gxp(:,:,:,1), gyp(:,:,:,1), gzp(:,:,:,1), ng_gp, &
                                         lo, hi, dx(n,:), &
                                         the_bc_level(n)%phys_bc_level_array(0,:,:), &
                                         the_bc_level(n)%phys_bc_level_array(i,:,:))

          end select
       end do
    end do

    ! make edge states consistent across levels
    do n = nlevs,2,-1
       do i = 1, dm
          call ml_edge_restriction_c(umac(n-1,i),1,umac(n,i),1,mla%mba%rr(n-1,:),i,1)
          call ml_edge_restriction_c(gphi_mac(n-1,i),1,gphi_mac(n,i),1,mla%mba%rr(n-1,:),i,1)
       enddo
    enddo

  end subroutine add_grad_scalar_mac

  subroutine add_grad_scalar_2d_mac(umac, vmac, ng_um, &
                                    gphi_x, gphi_y, ng_gp, &
                                    lo, hi, dx, &
                                    domain_phys_bc, box_phys_bc)

    use     bc_module
    use probin_module, only: prob_lo

    integer         , intent(in   ) :: lo(:), hi(:), ng_um, ng_gp
    real (kind=dp_t), intent(inout) ::   umac(lo(1)-ng_um:,lo(2)-ng_um:)
    real (kind=dp_t), intent(inout) ::   vmac(lo(1)-ng_um:,lo(2)-ng_um:)
    real (kind=dp_t), intent(inout) :: gphi_x(lo(1)-ng_gp:,lo(2)-ng_gp:)
    real (kind=dp_t), intent(inout) :: gphi_y(lo(1)-ng_gp:,lo(2)-ng_gp:)
    real (kind=dp_t), intent(in   ) :: dx(:)
    integer         , intent(in   ) :: domain_phys_bc(:,:)
    integer         , intent(in   ) :: box_phys_bc(:,:)

    ! Local variables
    integer :: i, j
    real (kind=dp_t) :: x, y
    real (kind=dp_t), allocatable :: phi(:,:)

    allocate(phi(lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1))

    if (domain_phys_bc(1,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(1,2) .eq. SLIP_WALL .and. &
        domain_phys_bc(2,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(2,2) .eq. SLIP_WALL) then

       ! Add on the gradient of a scalar (phi) that satisfies
       ! grad(phi).n = 0.

       ! x-velocity  (x are edges, y are centers)
       do j = lo(2), hi(2)
          y = (dble(j)+HALF)*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)+1
             x = (dble(i))*dx(1) + prob_lo(1)

             gphi_x(i,j) =  FOUR*x*(ONE - x)
             umac(i,j) = umac(i,j) + gphi_x(i,j)

          enddo
       enddo

       ! y-velocity  (x are centers, y are edges)
       do j = lo(2), hi(2)+1
          y = (dble(j))*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)
             x = (dble(i)+HALF)*dx(1) + prob_lo(1)

             gphi_y(i,j) =  FOUR*y*(ONE - y)
             vmac(i,j) = vmac(i,j) + gphi_y(i,j)

          enddo
       enddo

    else if (domain_phys_bc(1,1) .eq. PERIODIC .and. &
             domain_phys_bc(1,2) .eq. PERIODIC .and. &
             domain_phys_bc(2,1) .eq. PERIODIC .and. &
             domain_phys_bc(2,2) .eq. PERIODIC) then

       do j = lo(2)-1, hi(2)+1
          y = (dble(j)+0.5d0)*dx(2) + prob_lo(2)

          do i = lo(1)-1, hi(1)+1
             x = (dble(i)+0.5d0)*dx(1) + prob_lo(1)

               phi(i,j) = 0.1d0 * cos(2.d0*M_PI*y)*cos(2.d0*M_PI*x)

          enddo
       enddo

       ! x-velocity  (x are edges, y are centers)
       do j = lo(2), hi(2)
          y = (dble(j)+HALF)*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)+1
             x = (dble(i))*dx(1) + prob_lo(1)

             gphi_x(i,j) = (phi(i,j) - phi(i-1,j))/dx(1)
             umac(i,j) = umac(i,j) + gphi_x(i,j)

          enddo
       enddo

       ! y-velocity  (x are centers, y are edges)
       do j = lo(2), hi(2)+1
          y = (dble(j))*dx(2) + prob_lo(2)

          do i = lo(1), hi(1)
             x = (dble(i)+HALF)*dx(1) + prob_lo(1)

             gphi_y(i,j) = (phi(i,j) - phi(i,j-1))/dx(2)
             vmac(i,j) = vmac(i,j) + gphi_y(i,j)

          enddo
       enddo

    else
       call bl_error('Not set up for these boundary conditions')
    end if

    ! impose BCs

    ! x lo
    select case (box_phys_bc(1,1))
    case (SLIP_WALL)
       umac(lo(1),lo(2):hi(2)) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid x lo BC")
    end select

    ! x hi
    select case(box_phys_bc(1,2))
    case (SLIP_WALL)
       umac(hi(1)+1,lo(2):hi(2)) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid x hi BC")
    end select

    ! y lo
    select case (box_phys_bc(2,1))
    case (SLIP_WALL)
       vmac(lo(1):hi(1),lo(2)) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid y lo BC")
    end select

    ! y hi
    select case(box_phys_bc(2,2))
    case (SLIP_WALL)
       vmac(lo(1):hi(1),hi(2)+1) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid y hi BC")
    end select

    deallocate(phi)

  end subroutine add_grad_scalar_2d_mac

  subroutine add_grad_scalar_3d_mac(umac, vmac, wmac, ng_um, &
                                    gphi_x, gphi_y, gphi_z, ng_gp, &
                                    lo, hi, dx, &
                                    domain_phys_bc, box_phys_bc)

    use     bc_module
    use probin_module, only: prob_lo

    integer         , intent(in   ) :: lo(:), hi(:), ng_um, ng_gp
    real (kind=dp_t), intent(inout) ::   umac(lo(1)-ng_um:,lo(2)-ng_um:,lo(3)-ng_um:)
    real (kind=dp_t), intent(inout) ::   vmac(lo(1)-ng_um:,lo(2)-ng_um:,lo(3)-ng_um:)
    real (kind=dp_t), intent(inout) ::   wmac(lo(1)-ng_um:,lo(2)-ng_um:,lo(3)-ng_um:)
    real (kind=dp_t), intent(inout) :: gphi_x(lo(1)-ng_gp:,lo(2)-ng_gp:,lo(3)-ng_gp:)
    real (kind=dp_t), intent(inout) :: gphi_y(lo(1)-ng_gp:,lo(2)-ng_gp:,lo(3)-ng_gp:)
    real (kind=dp_t), intent(inout) :: gphi_z(lo(1)-ng_gp:,lo(2)-ng_gp:,lo(3)-ng_gp:)
    real (kind=dp_t), intent(in   ) :: dx(:)
    integer         , intent(in   ) :: domain_phys_bc(:,:)
    integer         , intent(in   ) :: box_phys_bc(:,:)

    ! Local variables
    integer :: i, j, k
    real (kind=dp_t) :: x, y, z
    real (kind=dp_t), allocatable :: phi(:,:,:)

    allocate(phi(lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1,lo(3)-1:hi(3)+1))

    if (domain_phys_bc(1,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(1,2) .eq. SLIP_WALL .and. &
        domain_phys_bc(2,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(2,2) .eq. SLIP_WALL .and. &
        domain_phys_bc(3,1) .eq. SLIP_WALL .and. &
        domain_phys_bc(3,2) .eq. SLIP_WALL) then

       ! Add on the gradient of a scalar (phi) that satisfies
       ! grad(phi).n = 0.

       ! x-velocity  (x are edges, y and z are centers)
       do k = lo(3), hi(3)
          z = (dble(k)+HALF)*dx(3) + prob_lo(3)

          do j = lo(2), hi(2)
             y = (dble(j)+HALF)*dx(2) + prob_lo(2)

             do i = lo(1), hi(1)+1
                x = (dble(i))*dx(1) + prob_lo(1)

                gphi_x(i,j,k) =  160.0_dp_t*x*(ONE - x)
                umac(i,j,k) = umac(i,j,k) + gphi_x(i,j,k)

             enddo
          enddo
       enddo

       ! y-velocity  (x and z are centers, y are edges)
       do k = lo(3), hi(3)
          z = (dble(k)+HALF)*dx(3) + prob_lo(3)

          do j = lo(2), hi(2)+1
             y = (dble(j))*dx(2) + prob_lo(2)

             do i = lo(1), hi(1)
                x = (dble(i)+HALF)*dx(1) + prob_lo(1)

                gphi_y(i,j,k) =  160.0_dp_t*y*(ONE - y)
                vmac(i,j,k) = vmac(i,j,k) + gphi_y(i,j,k)

             enddo
          enddo
       enddo

       ! z-velocity  (x and y are centers, z are edges)
       do k = lo(3), hi(3)+1
          z = (dble(k))*dx(3) + prob_lo(3)

          do j = lo(2), hi(2)
             y = (dble(j)+HALF)*dx(2) + prob_lo(2)

             do i = lo(1), hi(1)
                x = (dble(i)+HALF)*dx(1) + prob_lo(1)

                gphi_z(i,j,k) =  160.0_dp_t*z*(ONE - z)
                wmac(i,j,k) = wmac(i,j,k) + gphi_z(i,j,k)

             enddo
          enddo
       enddo

    else if (domain_phys_bc(1,1) .eq. PERIODIC .and. &
             domain_phys_bc(1,2) .eq. PERIODIC .and. &
             domain_phys_bc(2,1) .eq. PERIODIC .and. &
             domain_phys_bc(2,2) .eq. PERIODIC .and. &
             domain_phys_bc(3,1) .eq. PERIODIC .and. &
             domain_phys_bc(3,2) .eq. PERIODIC) then

       do k = lo(3)-1, hi(3)+1
          z = (dble(k)+HALF)*dx(3) + prob_lo(3)

          do j = lo(2)-1, hi(2)+1
             y = (dble(j)+HALF)*dx(2) + prob_lo(2)

             do i = lo(1)-1, hi(1)+1
                x = (dble(i)+HALF)*dx(1) + prob_lo(1)

                phi(i,j,k) = 5.0d0 * cos(2.d0*M_PI*y)*cos(2.d0*M_PI*x)*cos(2.d0*M_PI*z)
             enddo
          enddo
       enddo

       ! x-velocity  (x are edges, y and z are centers)
       do k = lo(3), hi(3)
          z = (dble(k)+HALF)*dx(3) + prob_lo(3)

          do j = lo(2), hi(2)
             y = (dble(j)+HALF)*dx(2) + prob_lo(2)

             do i = lo(1), hi(1)+1
                x = (dble(i))*dx(1) + prob_lo(1)

                gphi_x(i,j,k) = (phi(i,j,k) - phi(i-1,j,k))/dx(1)
                umac(i,j,k) = umac(i,j,k) + gphi_x(i,j,k)

             enddo
          enddo
       enddo

       ! y-velocity  (x and z are centers, y are edges)
       do k = lo(3), hi(3)
          z = (dble(k)+HALF)*dx(3) + prob_lo(3)

          do j = lo(2), hi(2)+1
             y = (dble(j))*dx(2) + prob_lo(2)

             do i = lo(1), hi(1)
                x = (dble(i)+HALF)*dx(1) + prob_lo(1)

                gphi_y(i,j,k) = (phi(i,j,k) - phi(i,j-1,k))/dx(2)
                vmac(i,j,k) = vmac(i,j,k) + gphi_y(i,j,k)

             enddo
          enddo
       enddo

       ! z-velocity  (x and y are centers, z are edges)
       do k = lo(3), hi(3)+1
          z = (dble(k))*dx(3) + prob_lo(3)

          do j = lo(2), hi(2)
             y = (dble(j)+HALF)*dx(2) + prob_lo(2)

             do i = lo(1), hi(1)
                x = (dble(i)+HALF)*dx(1) + prob_lo(1)

                gphi_z(i,j,k) = (phi(i,j,k) - phi(i,j,k-1))/dx(3)
                wmac(i,j,k) = wmac(i,j,k) + gphi_z(i,j,k)

             enddo
          enddo
       enddo

    else
       call bl_error('Not set up for these boundary conditions')
    end if

    ! impose BCs

    ! x lo
    select case (box_phys_bc(1,1))
    case (SLIP_WALL)
       umac(lo(1),lo(2):hi(2),lo(3):hi(3)) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid x lo BC")
    end select

    ! x hi
    select case(box_phys_bc(1,2))
    case (SLIP_WALL)
       umac(hi(1)+1,lo(2):hi(2),lo(3):hi(3)) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid x hi BC")
    end select

    ! y lo
    select case (box_phys_bc(2,1))
    case (SLIP_WALL)
       vmac(lo(1):hi(1),lo(2),lo(3):hi(3)) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid y lo BC")
    end select

    ! y hi
    select case(box_phys_bc(2,2))
    case (SLIP_WALL)
       vmac(lo(1):hi(1),hi(2)+1,lo(3):hi(3)) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid y hi BC")
    end select

    ! z lo
    select case (box_phys_bc(3,1))
    case (SLIP_WALL)
       wmac(lo(1):hi(1),lo(2):hi(2),lo(3)) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid z lo BC")
    end select

    ! z hi
    select case(box_phys_bc(3,2))
    case (SLIP_WALL)
       wmac(lo(1):hi(1),lo(2):hi(2),hi(3)+1) = ZERO
    case (PERIODIC, INTERIOR)
    case default
       call bl_error("invalid z hi BC")
    end select

    deallocate(phi)

  end subroutine add_grad_scalar_3d_mac

  !===========================================================================
  subroutine convert_MAC_to_cc(umac, u)

    ! convert a MAC velocity field to a cell-centered one -- no ghost
    ! cell filling is done here.

    integer :: n, i, ng_um, ng_u, dm, nlevs

    type(multifab) , intent(in   ) :: umac(:,:)
    type(multifab) , intent(inout) :: u(:)

    integer :: lo(get_dim(u(1))), hi(get_dim(u(1)))

    real(kind=dp_t), pointer :: ump(:,:,:,:), vmp(:,:,:,:), wmp(:,:,:,:)
    real(kind=dp_t), pointer :: up(:,:,:,:)

    nlevs = size(u)
    dm = get_dim(u(1))

    ng_u  = nghost(u(1))
    ng_um = nghost(umac(1,1))

    do n=1,nlevs
       do i = 1, nfabs(u(n))
          up => dataptr(u(n), i)

          ump => dataptr(umac(n,1), i)
          vmp => dataptr(umac(n,2), i)

          lo = lwb(get_box(u(n), i))
          hi = upb(get_box(u(n), i))

          select case (dm)
          case (2)
             call convert_MAC_to_cc_2d(ump(:,:,1,1), vmp(:,:,1,1), ng_um, &
                                       up(:,:,1,:), ng_u, lo, hi)

          case (3)
             wmp => dataptr(umac(n,3), i)
             call convert_MAC_to_cc_3d(ump(:,:,:,1), vmp(:,:,:,1), wmp(:,:,:,1), ng_um, &
                                       up(:,:,:,:), ng_u, lo, hi)

          end select
       end do
    end do

  end subroutine convert_MAC_to_cc

  subroutine convert_MAC_to_cc_2d(umac, vmac, ng_um, u, ng_u, lo, hi)

    integer         , intent(in   ) :: lo(:), hi(:), ng_um, ng_u
    real (kind=dp_t), intent(in   ) :: umac(lo(1)-ng_um:,lo(2)-ng_um:)
    real (kind=dp_t), intent(in   ) :: vmac(lo(1)-ng_um:,lo(2)-ng_um:)
    real (kind=dp_t), intent(inout) ::    u(lo(1)-ng_u :,lo(2)-ng_u :,:)

    integer :: i, j

    do j = lo(2), hi(2)
       do i = lo(1), hi(1)

          u(i,j,1) = HALF*(umac(i,j) + umac(i+1,j))
          u(i,j,2) = HALF*(vmac(i,j) + vmac(i,j+1))

       enddo
    enddo

  end subroutine convert_MAC_to_cc_2d

  subroutine convert_MAC_to_cc_3d(umac, vmac, wmac, ng_um, u, ng_u, lo, hi)

    integer         , intent(in   ) :: lo(:), hi(:), ng_um, ng_u
    real (kind=dp_t), intent(in   ) :: umac(lo(1)-ng_um:,lo(2)-ng_um:,lo(3)-ng_um:)
    real (kind=dp_t), intent(in   ) :: vmac(lo(1)-ng_um:,lo(2)-ng_um:,lo(3)-ng_um:)
    real (kind=dp_t), intent(in   ) :: wmac(lo(1)-ng_um:,lo(2)-ng_um:,lo(3)-ng_um:)
    real (kind=dp_t), intent(inout) ::    u(lo(1)-ng_u :,lo(2)-ng_u :,lo(3)-ng_u :,:)

    integer :: i, j, k

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             u(i,j,k,1) = HALF*(umac(i,j,k) + umac(i+1,j,k))
             u(i,j,k,2) = HALF*(vmac(i,j,k) + vmac(i,j+1,k))
             u(i,j,k,3) = HALF*(wmac(i,j,k) + wmac(i,j,k+1))

          enddo
       enddo
    enddo

  end subroutine convert_MAC_to_cc_3d

end module test_projection_module