module stochastic_n_fluxdiv_module

  use bl_types
  use bl_constants_module
  use multifab_module
  use ml_layout_module
  use define_bc_module
  use bc_module
  use multifab_fill_random_module
  use multifab_physbc_module
  use average_to_faces_module
  use div_and_grad_module
  use bl_rng_module
  use probin_common_module, only: variance_coef_mass, initial_variance, density_weights
  use probin_reactdiff_module, only: nspecies, cross_section, use_bl_rng

  implicit none

  private

  public :: stochastic_n_fluxdiv, fill_mass_stochastic, &
       init_mass_stochastic, destroy_mass_stochastic, &
       add_init_n_fluctuations

  ! stochastic fluxes for mass densities are face-centered
  type(multifab), allocatable, save :: stoch_W_fc(:,:,:)

  integer, save :: n_rngs ! how many random number stages

contains

  ! This computes div (sqrt(2*variance*D*n_cc / (dt*dV)) * W ) where W is a collection of i.i.d. standard normal variates
  ! It can easily be generalized to compute
  !  div (sqrt(2*variance*D*n_cc / (dt*dV)) * (alpha*W_1+beta*W_2) ) if n_rng=2
  !  but this is not used or implemented at present
  subroutine stochastic_n_fluxdiv(mla,n_cc,diff_coef_face,stoch_fluxdiv,dx,dt, &
                                  the_bc_tower,increment_in)

    type(ml_layout), intent(in   )  :: mla
    type(multifab) , intent(in   )  :: n_cc(:)
    type(multifab) , intent(in   )  :: diff_coef_face(:,:)
    type(multifab) , intent(inout)  :: stoch_fluxdiv(:)
    real(kind=dp_t), intent(in   )  :: dx(:,:)
    real(kind=dp_t), intent(in   )  :: dt
    type(bc_tower) , intent(in   )  :: the_bc_tower
    logical  , intent(in), optional :: increment_in ! Increment or overwrite stoch_fluxdiv argument?

    integer :: i,dm,n,nlevs
    real(kind=dp_t)  :: variance, dv

    type(multifab) :: flux(mla%nlevel,mla%dim)

    logical :: increment_div

    type(bl_prof_timer), save :: bpt

    call build(bpt,"stochastic_n_fluxdiv")

    dm = mla%dim
    nlevs = mla%nlevel

    dv = product(dx(1,1:dm))*cross_section

    increment_div = .false.
    if (present(increment_in)) increment_div = increment_in

    ! single cell case set stochastic mass fluxdiv to zero
    ! (or its increment if increment_in=T) and return
    if ((multifab_volume(n_cc(1))/nspecies)<=1) then
       if (.not. increment_div) then
          do n=1,nlevs
             call multifab_setval(stoch_fluxdiv(n),0.d0,all=.true.)
          end do
       end if
       return
    end if

    do n=1,nlevs
       do i=1,dm
          call multifab_build_edge(flux(n,i),mla%la(n),nspecies,0,i)
       end do
    end do

    ! average n to faces, store in "flux" so as to avoid an extra multifab
    ! alternatively one could multiply diff_coeff_face with this number
    call average_to_faces(mla,n_cc,flux,1,1,nspecies,dv)

    ! assumble fluxes on faces, sqrt(2*D_k*n_k / (dt*dV)) * random_normal
    variance = sqrt(2.d0*variance_coef_mass/(dv*dt))
    call assemble_stoch_n_fluxes(mla,n_cc,diff_coef_face,flux)
    do n=1,nlevs
       do i=1,dm
          call multifab_mult_mult_s(flux(n,i), variance, 0)
       end do
    end do

    ! take flux divergence
    call compute_div(mla,flux,stoch_fluxdiv,dx,1,1,nspecies, &
                     increment_in=increment_div)

    do n=1,nlevs
       do i=1,dm
          call multifab_destroy(flux(n,i))
       end do
    end do

    call destroy(bpt)

  end subroutine stochastic_n_fluxdiv

  subroutine assemble_stoch_n_fluxes(mla,n_cc,diff_coef_face,flux)

    ! note: n averaged to faces is stored in "flux" on entry to this subroutine

    type(ml_layout), intent(in   )  :: mla
    type(multifab) , intent(in   )  :: n_cc(:)
    type(multifab) , intent(in   )  :: diff_coef_face(:,:)
    type(multifab) , intent(inout)  :: flux(:,:) ! On input this contains the face-averaged number densities

    integer :: i,dm,n,nlevs,lo(mla%dim),hi(mla%dim)
    integer :: ng_n,ng_d,ng_f,ng_s

    real(kind=dp_t), pointer :: np(:,:,:,:)
    real(kind=dp_t), pointer :: dx(:,:,:,:)
    real(kind=dp_t), pointer :: dy(:,:,:,:)
    real(kind=dp_t), pointer :: dz(:,:,:,:)
    real(kind=dp_t), pointer :: fx(:,:,:,:)
    real(kind=dp_t), pointer :: fy(:,:,:,:)
    real(kind=dp_t), pointer :: fz(:,:,:,:)
    real(kind=dp_t), pointer :: sx(:,:,:,:)
    real(kind=dp_t), pointer :: sy(:,:,:,:)
    real(kind=dp_t), pointer :: sz(:,:,:,:)

    type(mfiter) :: mfi
    type(box) :: xnodalbox, ynodalbox, znodalbox
    integer :: xlo(mla%dim), xhi(mla%dim)
    integer :: ylo(mla%dim), yhi(mla%dim)
    integer :: zlo(mla%dim), zhi(mla%dim)

    type(bl_prof_timer), save :: bpt

    call build(bpt,"assemble_stoch_n_fluxes")

    dm = mla%dim
    nlevs = mla%nlevel

    ng_n = n_cc(1)%ng
    ng_d = diff_coef_face(1,1)%ng
    ng_f = flux(1,1)%ng
    ng_s = stoch_W_fc(1,1,1)%ng

    !$omp parallel private(mfi,n,i,xnodalbox,ynodalbox,znodalbox,xlo,ylo,zlo) &
    !$omp private(xhi,yhi,zhi,np,dx,dy,dz,fx,fy,fz,sx,sy,sz,lo,hi)
    do n=1,nlevs
       call mfiter_build(mfi, n_cc(n), tiling=.true.)
       do while (more_tile(mfi))
          i = get_fab_index(mfi)

          xnodalbox = get_nodaltilebox(mfi,1)
          xlo = lwb(xnodalbox)
          xhi = upb(xnodalbox)
          ynodalbox = get_nodaltilebox(mfi,2)
          ylo = lwb(ynodalbox)
          yhi = upb(ynodalbox)
          znodalbox = get_nodaltilebox(mfi,3)
          zlo = lwb(znodalbox)
          zhi = upb(znodalbox)

          np => dataptr(n_cc(n),i)
          dx => dataptr(diff_coef_face(n,1),i)
          dy => dataptr(diff_coef_face(n,2),i)
          fx => dataptr(flux(n,1),i)
          fy => dataptr(flux(n,2),i)
          sx => dataptr(stoch_W_fc(n,1,1),i)
          sy => dataptr(stoch_W_fc(n,2,1),i)
          lo = lwb(get_box(n_cc(n),i))
          hi = upb(get_box(n_cc(n),i))
          select case (dm)
          case (2)
             call assemble_stoch_n_fluxes_2d(np(:,:,1,:),ng_n, &
                                             dx(:,:,1,:),dy(:,:,1,:),ng_d, &
                                             fx(:,:,1,:),fy(:,:,1,:),ng_f, &
                                             sx(:,:,1,:),sy(:,:,1,:),ng_s, lo,hi, &
                                             xlo,xhi,ylo,yhi)
          case (3)
             dz => dataptr(diff_coef_face(n,3),i)
             fz => dataptr(flux(n,3),i)
             sz => dataptr(stoch_W_fc(n,3,1),i)
             call assemble_stoch_n_fluxes_3d(np(:,:,:,:),ng_n, &
                                             dx(:,:,:,:),dy(:,:,:,:),dz(:,:,:,:),ng_d, &
                                             fx(:,:,:,:),fy(:,:,:,:),fz(:,:,:,:),ng_f, &
                                             sx(:,:,:,:),sy(:,:,:,:),sz(:,:,:,:),ng_s, lo,hi, &
                                             xlo,xhi,ylo,yhi,zlo,zhi)
          end select
       end do
    end do
    !$omp end parallel

    ! sync the fluxes at the boundaries
    do n=1,nlevs
       do i=1,dm
          call multifab_internal_sync(flux(n,i))
          call multifab_fill_boundary(flux(n,i))
       end do
    end do

    call destroy(bpt)

  end subroutine assemble_stoch_n_fluxes

  subroutine assemble_stoch_n_fluxes_2d(n_cc,ng_n,coefx,coefy,ng_d,fluxx,fluxy,ng_f, &
                                        stochx,stochy,ng_s,glo,ghi, &
                                        xlo,xhi,ylo,yhi)

    integer        , intent(in   ) :: glo(:),ghi(:),ng_n,ng_d,ng_f,ng_s
    integer        , intent(in   ) :: xlo(:),xhi(:),ylo(:),yhi(:)
    real(kind=dp_t), intent(in   ) ::   n_cc(glo(1)-ng_n:,glo(2)-ng_n:,:)
    real(kind=dp_t), intent(in   ) ::  coefx(glo(1)-ng_d:,glo(2)-ng_d:,:)
    real(kind=dp_t), intent(in   ) ::  coefy(glo(1)-ng_d:,glo(2)-ng_d:,:)
    real(kind=dp_t), intent(inout) ::  fluxx(glo(1)-ng_f:,glo(2)-ng_f:,:)
    real(kind=dp_t), intent(inout) ::  fluxy(glo(1)-ng_f:,glo(2)-ng_f:,:)
    real(kind=dp_t), intent(in   ) :: stochx(glo(1)-ng_s:,glo(2)-ng_s:,:)
    real(kind=dp_t), intent(in   ) :: stochy(glo(1)-ng_s:,glo(2)-ng_s:,:)

    integer :: i,j

    ! x-fluxes
    do j=xlo(2),xhi(2)
       do i=xlo(1),xhi(1)
          fluxx(i,j,1:nspecies) = &
               sqrt(coefx(i,j,1:nspecies)*fluxx(i,j,1:nspecies))*stochx(i,j,1:nspecies)
       end do
    end do

    ! y-fluxes
    do j=ylo(2),yhi(2)
       do i=ylo(1),yhi(1)
          fluxy(i,j,1:nspecies) = &
               sqrt(coefy(i,j,1:nspecies)*fluxy(i,j,1:nspecies))*stochy(i,j,1:nspecies)
       end do
    end do

  end subroutine assemble_stoch_n_fluxes_2d

  subroutine assemble_stoch_n_fluxes_3d(n_cc,ng_n,coefx,coefy,coefz,ng_d,fluxx,fluxy,fluxz,ng_f, &
                                        stochx,stochy,stochz,ng_s,glo,ghi, &
                                        xlo,xhi,ylo,yhi,zlo,zhi)

    integer        , intent(in   ) :: glo(:),ghi(:),ng_n,ng_d,ng_f,ng_s
    integer        , intent(in   ) :: xlo(:),xhi(:),ylo(:),yhi(:),zlo(:),zhi(:)
    real(kind=dp_t), intent(in   ) ::   n_cc(glo(1)-ng_n:,glo(2)-ng_n:,glo(3)-ng_n:,:)
    real(kind=dp_t), intent(in   ) ::  coefx(glo(1)-ng_d:,glo(2)-ng_d:,glo(3)-ng_d:,:)
    real(kind=dp_t), intent(in   ) ::  coefy(glo(1)-ng_d:,glo(2)-ng_d:,glo(3)-ng_d:,:)
    real(kind=dp_t), intent(in   ) ::  coefz(glo(1)-ng_d:,glo(2)-ng_d:,glo(3)-ng_d:,:)
    real(kind=dp_t), intent(inout) ::  fluxx(glo(1)-ng_f:,glo(2)-ng_f:,glo(3)-ng_f:,:)
    real(kind=dp_t), intent(inout) ::  fluxy(glo(1)-ng_f:,glo(2)-ng_f:,glo(3)-ng_f:,:)
    real(kind=dp_t), intent(inout) ::  fluxz(glo(1)-ng_f:,glo(2)-ng_f:,glo(3)-ng_f:,:)
    real(kind=dp_t), intent(in   ) :: stochx(glo(1)-ng_s:,glo(2)-ng_s:,glo(3)-ng_s:,:)
    real(kind=dp_t), intent(in   ) :: stochy(glo(1)-ng_s:,glo(2)-ng_s:,glo(3)-ng_s:,:)
    real(kind=dp_t), intent(in   ) :: stochz(glo(1)-ng_s:,glo(2)-ng_s:,glo(3)-ng_s:,:)

    integer :: i,j,k

    ! x-fluxes
    do k=xlo(3),xhi(3)
       do j=xlo(2),xhi(2)
          do i=xlo(1),xhi(1)
             fluxx(i,j,k,1:nspecies) = &
                  sqrt(coefx(i,j,k,1:nspecies)*fluxx(i,j,k,1:nspecies))*stochx(i,j,k,1:nspecies)
          end do
       end do
    end do

    ! y-fluxes
    do k=ylo(3),yhi(3)
       do j=ylo(2),yhi(2)
          do i=ylo(1),yhi(1)
             fluxy(i,j,k,1:nspecies) = &
                  sqrt(coefy(i,j,k,1:nspecies)*fluxy(i,j,k,1:nspecies))*stochy(i,j,k,1:nspecies)
          end do
       end do
    end do

    ! z-fluxes
    do k=zlo(3),zhi(3)
       do j=zlo(2),zhi(2)
          do i=zlo(1),zhi(1)
             fluxz(i,j,k,1:nspecies) = &
                  sqrt(coefz(i,j,k,1:nspecies)*fluxz(i,j,k,1:nspecies))*stochz(i,j,k,1:nspecies)
          end do
       end do
    end do

  end subroutine assemble_stoch_n_fluxes_3d

  ! call this once at the beginning of simulation to allocate multifabs
  ! that will hold random numbers
  subroutine init_mass_stochastic(mla,n_rngs_in)

    type(ml_layout), intent(in   ) :: mla
    integer        , intent(in   ) :: n_rngs_in

    ! local
    integer :: n,nlevs,i,dm,rng

    type(bl_prof_timer), save :: bpt

    call build(bpt,"init_mass_stochastic")

    n_rngs = n_rngs_in

    nlevs = mla%nlevel
    dm = mla%dim

    allocate(stoch_W_fc(mla%nlevel, mla%dim, n_rngs))

    do n=1,nlevs
       do rng=1,n_rngs
          do i=1,dm
             ! we need one face-centered flux for each concentration
             call multifab_build_edge(stoch_W_fc(n,i,rng),mla%la(n),nspecies,0,i)
          end do
       end do ! end loop over n_rngs
    end do ! end loop over nlevs

    call destroy(bpt)

  end subroutine init_mass_stochastic

  ! call this once at the end of simulation to deallocate memory
  subroutine destroy_mass_stochastic(mla)

    type(ml_layout), intent(in   ) :: mla

    ! local
    integer :: n,nlevs,i,dm,rng

    type(bl_prof_timer), save :: bpt

    call build(bpt,"destroy_mass_stochastic")

    nlevs = mla%nlevel
    dm = mla%dim

    do n=1,nlevs
       do rng=1,n_rngs
          do i=1,dm
             call multifab_destroy(stoch_W_fc(n,i,rng))
          end do
       end do
    end do

    deallocate(stoch_W_fc)

    call destroy(bpt)

  end subroutine destroy_mass_stochastic

  subroutine fill_mass_stochastic(mla,the_bc_level)

    type(ml_layout), intent(in   )  :: mla
    type(bc_level) , intent(in   )  :: the_bc_level(:)

    ! Local variables
    integer :: dm,nlevs,box,i,rng

    type(bl_prof_timer), save :: bpt

    call build(bpt,"fill_mass_stochastic")

    nlevs = mla%nlevel
    dm    = mla%dim

    ! generate and store the stochastic flux (random numbers)
    if (use_bl_rng) then
       do rng=1, n_rngs
          do i = 1,dm
             call multifab_fill_random(stoch_W_fc(:,i,rng), rng_eng=rng_eng_diffusion)
          end do
       end do
    else
       do rng=1, n_rngs
          do i = 1,dm
             call multifab_fill_random(stoch_W_fc(:,i,rng))
          end do
       end do
    end if

    ! apply boundary conditions to stochastic fluxes
    call stoch_mass_bc(mla,the_bc_level)

    call destroy(bpt)

  end subroutine fill_mass_stochastic

  subroutine stoch_mass_bc(mla,the_bc_level)

    type(ml_layout), intent(in   )  :: mla
    type(bc_level) , intent(in   )  :: the_bc_level(:)

    ! local
    integer :: n,nlevs,dm,idim,rng,i,ng_f
    integer :: lo(mla%dim),hi(mla%dim)

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

    type(bl_prof_timer), save :: bpt

    call build(bpt,"stoch_mass_bc")

    nlevs = mla%nlevel
    dm = mla%dim

    ng_f = stoch_W_fc(1,1,1)%ng

    do n=1,nlevs
       do idim=1,dm
          do rng=1,n_rngs
             do i=1,nfabs(stoch_W_fc(n,idim,rng))
                fp => dataptr(stoch_W_fc(n,idim,rng),i)
                lo = lwb(get_box(stoch_W_fc(n,idim,rng),i))
                hi = upb(get_box(stoch_W_fc(n,idim,rng),i))
                select case (dm)
                case (2)
                   call stoch_mass_bc_2d(fp(:,:,1,:),ng_f,idim,lo,hi, &
                                         the_bc_level(n)%phys_bc_level_array(i,:,:))
                case (3)
                   call stoch_mass_bc_3d(fp(:,:,:,:),ng_f,idim,lo,hi, &
                                         the_bc_level(n)%phys_bc_level_array(i,:,:))
                end select
             end do
          end do
       end do
    end do

    call destroy(bpt)

  end subroutine stoch_mass_bc

  subroutine stoch_mass_bc_2d(sflux,ng_f,idim,lo,hi,phys_bc)

      integer        , intent(in   ) :: lo(:),hi(:),ng_f,idim
      integer        , intent(in   ) :: phys_bc(:,:)
      real(kind=dp_t), intent(inout) :: sflux(lo(1)-ng_f:,lo(2)-ng_f:,:)

      if (idim .eq. 1) then

         if (phys_bc(1,1) .eq. NO_SLIP_WALL .or. phys_bc(1,1) .eq. SLIP_WALL) then
            sflux(lo(1),lo(2):hi(2),:) = 0.d0
         end if

         if (phys_bc(1,2) .eq. NO_SLIP_WALL .or. phys_bc(1,2) .eq. SLIP_WALL) then
            sflux(hi(1)+1,lo(2):hi(2),:) = 0.d0
         end if

         if (phys_bc(1,1) .eq. NO_SLIP_RESERVOIR) then
            sflux(lo(1),lo(2):hi(2),:) = sqrt(2.0d0)*sflux(lo(1),lo(2):hi(2),:)
         end if

         if (phys_bc(1,2) .eq. NO_SLIP_RESERVOIR) then
            sflux(hi(1)+1,lo(2):hi(2),:) = sqrt(2.0d0)*sflux(hi(1)+1,lo(2):hi(2),:)
         end if

      else

         if (phys_bc(2,1) .eq. NO_SLIP_WALL .or. phys_bc(2,1) .eq. SLIP_WALL) then
            sflux(lo(1):hi(1),lo(2),:) = 0.d0
         end if

         if (phys_bc(2,2) .eq. NO_SLIP_WALL .or. phys_bc(2,2) .eq. SLIP_WALL) then
            sflux(lo(1):hi(1),hi(2)+1,:) = 0.d0
         end if

         if (phys_bc(2,1) .eq. NO_SLIP_RESERVOIR) then
            sflux(lo(1):hi(1),lo(2),:) = sqrt(2.0d0)*sflux(lo(1):hi(1),lo(2),:)
         end if

         if (phys_bc(2,2) .eq. NO_SLIP_RESERVOIR) then
            sflux(lo(1):hi(1),hi(2)+1,:) = sqrt(2.0d0)*sflux(lo(1):hi(1),hi(2)+1,:)
         end if

      end if

  end subroutine stoch_mass_bc_2d

  subroutine stoch_mass_bc_3d(sflux,ng_f,idim,lo,hi,phys_bc)

      integer        , intent(in   ) :: lo(:),hi(:),ng_f,idim
      integer        , intent(in   ) :: phys_bc(:,:)
      real(kind=dp_t), intent(inout) :: sflux(lo(1)-ng_f:,lo(2)-ng_f:,lo(3)-ng_f:,:)

      if (idim .eq. 1) then

         if (phys_bc(1,1) .eq. NO_SLIP_WALL .or. phys_bc(1,1) .eq. SLIP_WALL) then
            sflux(lo(1),lo(2):hi(2),lo(3):hi(3),:) = 0.d0
         end if

         if (phys_bc(1,2) .eq. NO_SLIP_WALL .or. phys_bc(1,2) .eq. SLIP_WALL) then
            sflux(hi(1)+1,lo(2):hi(2),lo(3):hi(3),:) = 0.d0
         end if

         if (phys_bc(1,1) .eq. NO_SLIP_RESERVOIR) then
            sflux(lo(1),lo(2):hi(2),lo(3):hi(3),:) = sqrt(2.0d0)*sflux(lo(1),lo(2):hi(2),lo(3):hi(3),:)
         end if

         if (phys_bc(1,2) .eq. NO_SLIP_RESERVOIR) then
            sflux(hi(1)+1,lo(2):hi(2),lo(3):hi(3),:) = sqrt(2.0d0)*sflux(hi(1)+1,lo(2):hi(2),lo(3):hi(3),:)
         end if

      else if (idim .eq. 2) then

         if (phys_bc(2,1) .eq. NO_SLIP_WALL .or. phys_bc(2,1) .eq. SLIP_WALL) then
            sflux(lo(1):hi(1),lo(2),lo(3):hi(3),:) = 0.d0
         end if

         if (phys_bc(2,2) .eq. NO_SLIP_WALL .or. phys_bc(2,2) .eq. SLIP_WALL) then
            sflux(lo(1):hi(1),hi(2)+1,lo(3):hi(3),:) = 0.d0
         end if

         if (phys_bc(2,1) .eq. NO_SLIP_RESERVOIR) then
            sflux(lo(1):hi(1),lo(2),lo(3):hi(3),:) = sqrt(2.0d0)*sflux(lo(1):hi(1),lo(2),lo(3):hi(3),:)
         end if

         if (phys_bc(2,2) .eq. NO_SLIP_RESERVOIR) then
            sflux(lo(1):hi(1),hi(2)+1,lo(3):hi(3),:) = sqrt(2.0d0)*sflux(lo(1):hi(1),hi(2)+1,lo(3):hi(3),:)
         end if

      else

         if (phys_bc(3,1) .eq. NO_SLIP_WALL .or. phys_bc(3,1) .eq. SLIP_WALL) then
            sflux(lo(1):hi(1),lo(2):hi(2),lo(3),:) = 0.d0
         end if

         if (phys_bc(3,2) .eq. NO_SLIP_WALL .or. phys_bc(3,2) .eq. SLIP_WALL) then
            sflux(lo(1):hi(1),lo(2):hi(2),hi(3)+1,:) = 0.d0
         end if

         if (phys_bc(3,1) .eq. NO_SLIP_RESERVOIR) then
            sflux(lo(1):hi(1),lo(2):hi(2),lo(3),:) = sqrt(2.0d0)*sflux(lo(1):hi(1),lo(2):hi(2),lo(3),:)
         end if

         if (phys_bc(3,2) .eq. NO_SLIP_RESERVOIR) then
            sflux(lo(1):hi(1),lo(2):hi(2),hi(3)+1,:) = sqrt(2.0d0)*sflux(lo(1):hi(1),lo(2):hi(2),hi(3)+1,:)
         end if

      end if

  end subroutine stoch_mass_bc_3d

  subroutine add_init_n_fluctuations(mla,n_init,dx,the_bc_tower)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: n_init(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:)
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! local
    integer :: n,nlevs,dm,spec,n_cell
    real(kind=dp_t) :: dn_sum, dv

    type(multifab) :: n_temp(mla%nlevel)

    type(bl_prof_timer), save :: bpt

    call build(bpt,"add_init_n_fluctuations")

    nlevs = mla%nlevel
    dm = mla%dim

    dv = product(dx(1,1:dm))*cross_section

    ! the number of ghost cells must match variance_mfab input to multifab_fill_random
    ! the values in the ghost cells do not have to be added to n_init since we
    ! fill ghost cells for n_init afterwards
    do n=1,nlevs
       call multifab_build(n_temp(n),mla%la(n),nspecies,n_init(n)%ng)
    end do

    n_cell = multifab_volume(n_temp(1)) / nspecies

    ! create a multifab full of random numbers
    do n=1,nlevs

       if (use_bl_rng) then
          call multifab_fill_random(n_temp(n:n), &
                                    variance_mfab=n_init, &
                                    variance=abs(initial_variance)/dv, &  ! We do not multiply here by variance_coef_mass
                                    rng_eng=rng_eng_init)
       else
          call multifab_fill_random(n_temp(n:n), &
                                    variance_mfab=n_init, &
                                    variance=abs(initial_variance)/dv)  ! We do not multiply here by variance_coef_mass

       end if

       if(initial_variance<0.0d0) then
          ! Make sure this sums to zero
          do spec=1, nspecies
             dn_sum = multifab_sum_c(n_temp(n),spec,1) / dble(n_cell)
             call multifab_sub_sub_s_c(n_temp(n),spec,dn_sum,1,0)
          end do
       end if

    end do

    do n=1,nlevs
       if(.false..and.sum(abs(density_weights))>0.0d0) then ! For A+B<->C tests
          ! Generate only one random perturbation and weight it: dn_k = w_k * dn_0
          do spec=1,nspecies
             call multifab_saxpy_3_cc(n_init(n),spec,density_weights(spec),n_temp(n),1,1)
          end do
       else
          call multifab_plus_plus_c(n_init(n),1,n_temp(n),1,nspecies,0)
       end if
       call multifab_fill_boundary(n_init(n))
       call multifab_physbc(n_init(n),1,scal_bc_comp,nspecies, &
                            the_bc_tower%bc_tower_array(n),dx_in=dx(n,:))
    end do

    do n=1,nlevs
       call multifab_destroy(n_temp(n))
    end do

    call destroy(bpt)

  end subroutine add_init_n_fluctuations

end module stochastic_n_fluxdiv_module


! COPYRIGHT (c) 2014 Science and Technology Facilities Council
! Authors: Jonathan Hogg
!
! Implementation of simple LCG PRNG
! Parameters as in glibc
module spral_random
  implicit none

  private
  public :: random_real,& ! Returns random real
       random_integer,  & ! Returns random integer
       random_logical,  & ! Returns random logical
       random_get_seed, & ! Get seed of generator
       random_set_seed    ! Set seed of generator
  public :: random_state  ! State type

  integer, parameter :: wp = kind(0d0)
  integer, parameter :: long = selected_int_kind(18)

  ! LCG data
  integer(long), parameter :: a = 1103515245
  integer(long), parameter :: c = 12345
  integer(long), parameter :: m = 2**31_long

  ! Store random generator state
  type :: random_state
     private
     integer :: x = 486502
  end type random_state

  interface random_integer
     module procedure random_integer32, random_integer64
  end interface random_integer

contains

  !
  ! Get random seed
  !
  integer function random_get_seed(state)
    implicit none
    type(random_state), intent(in) :: state

    random_get_seed = state%x
  end function random_get_seed

  !
  ! Set random seed
  !
  subroutine random_set_seed(state, seed)
    implicit none
    type(random_state), intent(inout) :: state
    integer, intent(in) :: seed

    state%x = seed
  end subroutine random_set_seed

  !
  !  Real random number in the range
  !  [ 0, 1] (if positive is present and .TRUE.); or
  !  [-1, 1] (otherwise)
  !
  real(wp) function random_real(state, positive)
    implicit none
    type(random_state), intent(inout) :: state
    logical, optional, intent(in) :: positive

    logical :: pos

    pos = .false.
    if (present(positive)) pos = positive

    ! X_{n+1} = (aX_n + c) mod m
    state%x = int(mod(a*state%x+c, m))

    ! Convert to a random real
    if (pos) then
       random_real = real(state%x,wp) / real(m,wp)
    else
       random_real = 1.0 - 2.0*real(state%x,wp)/real(m,wp)
    end if
  end function random_real

  !
  !  Integer random number in the range [1,n] if n > 1.
  !  otherwise, the value n is returned
  !
  integer(long) function random_integer64(state, n)
    implicit none
    type(random_state), intent(inout) :: state
    integer(long), intent(in) :: n

    if (n .le. 0) then
       random_integer64 = n
       return
    end if

    ! X_{n+1} = (aX_n + c) mod m
    state%x = int(mod(a*state%x+c, m))

    ! Take modulo n for return value
    random_integer64 = int(state%x * (real(n,wp)/real(m,wp)), long) + 1
  end function random_integer64

  !
  !  Integer random number in the range [1,n] if n > 1.
  !  otherwise, the value n is returned
  !
  integer function random_integer32(state, n)
    implicit none
    type(random_state), intent(inout) :: state
    integer, intent(in) :: n

    ! Just call 64-bit version with type casts
    random_integer32 = int(random_integer64(state, int(n,long)))
  end function random_integer32

  !
  !  Generate a random logical value
  !
  logical function random_logical(state)
    implicit none
    type(random_state), intent(inout) :: state

    integer :: test

    test = random_integer(state, 2)
    random_logical = (test .eq. 1)
  end function random_logical

end module spral_random


      SUBROUTINE MPYL (A,B,NCOLA,NROWA,NCOLB,C)
C
C     SINCE CDC FORTRAN 5 IMPOSES NO LONGER EXACT NO. OF DUMMY ARGUMENT
C     LIST FOR SUBROUTINE AND ENTRY POINTS, THIS ROUTINE IS NOW MACHINE
C     INDEPENDENT.
C
      DIMENSION A(NCOLA,NROWA),B(NCOLB,NCOLA),C(NCOLB,NROWA)
      DIMENSION D(NROWA,NCOLA),X(3),Y(3),VECT(3)
C
C     SIMPLE MATRIX MULTIPLICATION
C
      DO 10 N= 1,NCOLB
      DO 10 L= 1,NROWA
      C(N,L) = 0.0
      DO 10 M= 1,NCOLA
   10 C(N,L) = C(N,L)+B(N,M)*A(M,L)
      RETURN
C
      ENTRY NORM (X,Y)
C     ================
C
C     NORMALIZE X VECTOR
C
      Y(1) = X(1)*X(1)+X(2)*X(2)+X(3)*X(3)
      IF (Y(1) .EQ. 0.0)  GO TO 15
      W    = 1./SQRT(Y(1))
      X(1) = X(1)*W
      X(2) = X(2)*W
      X(3) = X(3)*W
   15 RETURN
C
      ENTRY CROSS (X,Y,VECT)
C     ======================
C
C     CROSS PRODUCT
C
      VECT(1) = X(2)*Y(3)-X(3)*Y(2)
      VECT(2) = Y(1)*X(3)-X(1)*Y(3)
      VECT(3) = X(1)*Y(2)-Y(1)*X(2)
      RETURN
C
      ENTRY MPYLT (D,B,NCOLA,NROWA,NCOLB,C)
C     =====================================
C
C     TRANSPOSE MULTIPLY
C
      DO 20 N= 1,NCOLB
      DO 20 L= 1,NROWA
      C(N,L) = 0.0
      DO 20 M= 1,NCOLA
   20 C(N,L) = C(N,L)+D(L,M)*B(N,M)
      RETURN
      END


!*==dsdot.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b DSDOT
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,INCY,N
!       ..
!       .. Array Arguments ..
!       REAL SX(*),SY(*)
!       ..
!
!    AUTHORS
!    =======
!    Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
!    Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> Compute the inner product of two vectors with extended
!> precision accumulation and result.
!>
!> Returns D.P. dot product accumulated in D.P., for S.P. SX and SY
!> DSDOT = sum for I = 0 to N-1 of  SX(LX+I*INCX) * SY(LY+I*INCY),
!> where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
!> defined in a similar way using INCY.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] SX
!> \verbatim
!>          SX is REAL array, dimension(N)
!>         single precision vector with N elements
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>          storage spacing between elements of SX
!> \endverbatim
!>
!> \param[in] SY
!> \verbatim
!>          SY is REAL array, dimension(N)
!>         single precision vector with N elements
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>         storage spacing between elements of SY
!> \endverbatim
!>
!> \result DSDOT
!> \verbatim
!>          DSDOT is DOUBLE PRECISION
!>         DSDOT  double precision dot product (zero if N.LE.0)
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup double_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!> \endverbatim
!
!> \par References:
!  ================
!>
!> \verbatim
!>
!>
!>  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
!>  Krogh, Basic linear algebra subprograms for Fortran
!>  usage, Algorithm No. 539, Transactions on Mathematical
!>  Software 5, 3 (September 1979), pp. 308-323.
!>
!>  REVISION HISTORY  (YYMMDD)
!>
!>  791001  DATE WRITTEN
!>  890831  Modified array declarations.  (WRB)
!>  890831  REVISION DATE from Version 3.2
!>  891214  Prologue converted to Version 4.0 format.  (BAB)
!>  920310  Corrected definition of LX in DESCRIPTION.  (WRB)
!>  920501  Reformatted the REFERENCES section.  (WRB)
!>  070118  Reformat to LAPACK style (JL)
!> \endverbatim
!>
!  =====================================================================
      DOUBLE PRECISION FUNCTION DSDOT(N,Sx,Incx,Sy,Incy)
      IMPLICIT NONE
!*--DSDOT123
!
!  -- Reference BLAS level1 routine (version 3.7.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Incx , Incy , N
!     ..
!     .. Array Arguments ..
      REAL Sx(*) , Sy(*)
!     ..
!
!  Authors:
!  ========
!  Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
!  Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , kx , ky , ns
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DBLE
!     ..
      DSDOT = 0.0D0
      IF ( N<=0 ) RETURN
      IF ( Incx==Incy .AND. Incx>0 ) THEN
!
!     Code for equal, positive, non-unit increments.
!
         ns = N*Incx
         DO i = 1 , ns , Incx
            DSDOT = DSDOT + DBLE(Sx(i))*DBLE(Sy(i))
         ENDDO
      ELSE
!
!     Code for unequal or nonpositive increments.
!
         kx = 1
         ky = 1
         IF ( Incx<0 ) kx = 1 + (1-N)*Incx
         IF ( Incy<0 ) ky = 1 + (1-N)*Incy
         DO i = 1 , N
            DSDOT = DSDOT + DBLE(Sx(kx))*DBLE(Sy(ky))
            kx = kx + Incx
            ky = ky + Incy
         ENDDO
      ENDIF
      END FUNCTION DSDOT


subroutine lst_comp_norm ( &
     lo, hi, &
     soln, s_l1, s_l2, s_l3, s_h1, s_h2, s_h3,  &
     exac, e_l1, e_l2, e_l3, e_h1, e_h2, e_h3,  &
     mask, m_l1, m_l2, m_l3, m_h1, m_h2, m_h3,  &
     volb, v_l1, v_l2, v_l3, v_h1, v_h2, v_h3,  &
     norm2, norm0, volume, nsoln)

  implicit none

  integer, intent(in) :: lo(3), hi(3)
  integer, intent(in) :: nsoln
  integer, intent(in) :: s_l1, s_l2, s_l3, s_h1, s_h2, s_h3
  integer, intent(in) :: e_l1, e_l2, e_l3, e_h1, e_h2, e_h3
  integer, intent(in) :: m_l1, m_l2, m_l3, m_h1, m_h2, m_h3
  integer, intent(in) :: v_l1, v_l2, v_l3, v_h1, v_h2, v_h3
  double precision, intent(inout) :: norm2(0:nsoln-1), norm0(0:nsoln-1), volume
  double precision, intent(in) :: soln(s_l1:s_h1, s_l2:s_h2, s_l3:s_h3, 0:nsoln-1)
  double precision, intent(in) :: exac(e_l1:e_h1, e_l2:e_h2, e_l3:e_h3)
  double precision, intent(in) :: mask(m_l1:m_h1, m_l2:m_h2, m_l3:m_h3)
  double precision, intent(in) :: volb(v_l1:v_h1, v_l2:v_h2, v_l3:v_h3)

  integer :: i, j, k, isoln
  double precision :: error

  do k = lo(3), hi(3)
     do j = lo(2), hi(2)
        do i = lo(1), hi(1)
           if (mask(i,j,k) .gt. 0.d0) then
              volume = volume + volb(i,j,k)

              do isoln = 0, nsoln-1
                 error = soln(i,j,k,isoln)-exac(i,j,k)
                 norm2(isoln) = norm2(isoln) + error**2 * volb(i,j,k)
                 norm0(isoln) = max(norm0(isoln), abs(error))
              end do
           end if
        end do
     end do
  end do

end subroutine lst_comp_norm


module riemann_mod

use globals_mod

contains

pure function xriemann(u_L,u_R) result(sflux)

    use equations_mod, only: N_VARS
    use equations_mod, only: flux => xflux
    use equations_mod, only: lambdaMax => xlambdaMax

    real(dp), intent(in) :: u_L(N_VARS), u_R(N_VARS)
    real(dp)             :: sflux(N_VARS)

    real(dp) :: F_L(N_VARS), F_R(N_VARS), lmax

    F_L = flux(u_L)
    F_R = flux(u_R)

    lMax = max(lambdaMax(u_L),lambdaMax(u_R))

    sflux = 0.5*(F_L + F_R + lMax*(u_L - u_R))

end function

pure function yriemann(inflow,exflow) result(sflux)

    use equations_mod

    real(dp), intent(in) :: inflow(N_VARS), exflow(N_VARS)
    real(dp)             :: sflux(N_VARS)

    real(dp) :: rinflow(N_VARS), rexflow(N_VARS), rflux(N_VARS) !! rotated

    rinflow(DENS_VAR) = inflow(DENS_VAR)
    rinflow(MOMX_VAR) = inflow(MOMY_VAR)
    rinflow(MOMY_VAR) = inflow(MOMX_VAR)
    rinflow(ENER_VAR) = inflow(ENER_VAR)

    rexflow(DENS_VAR) = exflow(DENS_VAR)
    rexflow(MOMX_VAR) = exflow(MOMY_VAR)
    rexflow(MOMY_VAR) = exflow(MOMX_VAR)
    rexflow(ENER_VAR) = exflow(ENER_VAR)

    rflux = xriemann(rinflow,rexflow)

    sflux(DENS_VAR) = rflux(DENS_VAR)
    sflux(MOMX_VAR) = rflux(MOMY_VAR)
    sflux(MOMY_VAR) = rflux(MOMX_VAR)
    sflux(ENER_VAR) = rflux(ENER_VAR)

end function

end module


program ibancheck

   use ISO_FORTRAN_ENV

   implicit none

   character(4), dimension(75) :: cc = (/ &
            "AD24","AE23","AL28","AT20","AZ28","BA20","BE16","BG22","BH22","BR29", &
            "BY28","CH21","CR22","CY28","CZ24","DE22","DK18","DO28","EE20","ES24", &
            "FI18","FO18","FR27","GB22","GE22","GI23","GL18","GR27","GT28","HR21", &
            "HU28","IE22","IL23","IQ23","IS26","IT27","JO30","KW30","KZ20","LB28", &
            "LC32","LI21","LT20","LU20","LV21","MC27","MD24","ME22","MK19","MR27", &
            "MT31","MU30","NL18","NO15","PK24","PL28","PS29","PT25","QA29","RO24", &
            "RS22","SA24","SC31","SE24","SI19","SK24","SM27","ST25","SV28","TL23", &
            "TN24","TR26","UA29","VG24","XK20" /)

    character(34), dimension(12) :: ibans = (/ "GB82 WEST 1234 5698 7654 32       ", &
                                               "GB82WEST12345698765432            ", &
                                               "gb82 west 1234 5698 7654 32       ", &
                                               "GB82 TEST 1234 5698 7654 32       ", &
                                               "GR16 0110 1250 0000 0001 2300 695 ", &
                                               "GB29 NWBK 6016 1331 9268 19       ", &
                                               "SA03 8000 0000 6080 1016 7519     ", &
                                               "CH93 0076 2011 6238 5295 7        ", &
                                               "IL62 0108 0000 0009 9999 999      ", &
                                               "IL62-0108-0000-0009-9999-999      ", &
                                               "US12 3456 7890 0987 6543 210      ", &
                                               "GR16 0110 1250 0000 0001 2300 695X" /)

    integer :: i

    do i=1, size(ibans)
        if (checkIBAN(trim(ibans(i)))) then
            print *, "  valid IBAN: ", trim(ibans(i))
        else
            print *, "invalid IBAN: ", trim(ibans(i))
        end if
    end do

    return

contains

    function checkIBAN(ibancode) result(valid)
        character(len=*), intent(in) :: ibancode
        character(len=len(ibancode)) :: iban
        logical :: valid
        integer(int32) :: j, ascii, ibanSize
        character(100) :: ibanRearrange, ibantoint
        character(2) :: temp
        valid = .false.

        iban = remove_blanks(ibancode)
        ibanSize = checkCountryCode(iban)
        if (ibanSize == len(trim(iban))) then
            ibanRearrange = iban(5:ibanSize)//iban(1:4)
            ibantoint = ""
            do j=1, ibanSize
                ascii = ichar(ibanRearrange(j:j))
                if ((ascii >= 65) .and. (ascii<=90)) then
                    write (temp,fmt='(I2)') ascii-55
                    ibantoint = trim(ibantoint) // temp
                else
                    ibantoint = trim(ibantoint) // ibanRearrange(j:j)
                end if
            end do
            if (mod97(ibantoint) == 1) then
                valid = .true.
            end if
        end if
    end function checkIBAN

    function mod97(strint) result(res)
        character(len=*), intent(in) :: strint
        integer :: i, num, res
        res = 0
        do  i=1, len(trim(strint))
            read(strint(i:i),*) num
            res = mod((res*10 + num),97);
        end do
    end function mod97

    function checkCountryCode(iban) result(ibanlength)
        character(len=*), intent(in) :: iban
        integer(int16) :: ibanlength, i
        ibanlength = 0
        do i=1, size(cc)
            if (iban(1:2) == cc(i)(1:2)) then
                read(cc(i)(3:4),*) ibanlength
                exit
            end if
        end do
    end function checkCountryCode

    Recursive Function Stripper(string,ch) Result(stripped)
        Implicit None
        character(len=*), intent(in) :: string
        character, intent(in) :: ch
        character(:), allocatable :: stripped

        IF (LEN(string)==1) THEN
           IF (string==ch) THEN
              stripped = ''
           ELSE
              stripped = string
           END IF
        ELSE
           IF (string(1:1)==ch) THEN
              stripped = stripper(string(2:),ch)
           ELSE
              stripped = string(1:1)//stripper(string(2:),ch)
           END IF
        END IF
    END Function stripper

    Function Remove_Blanks(string) Result(stripped)
        Implicit None
        character(len=*), intent(in) ::   string
        character(:), allocatable :: stripped

        stripped = trim(Stripper(trim(Stripper(string,' ')),achar(9)))
    END Function Remove_Blanks

end program ibancheck


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C             MINIM2.FOR : Routine de minimisation
C
C dernière modification : 09.02.97
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE MINIM2(A,X,B,G,Z,EPS,F0,N,METH,IASS,NCHECK,
     #                  ICONST,ISA,ITER)

C     Déclaration des variables
C     -------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A((N*(N+1))/2),X(1),B(1),G(1),Z(1),ISA(*)
C
C     Ouverture du fichier résultat
C     -----------------------------
C     OPEN(UNIT = 1, FILE = 'RES.M', STATUS = 'UNKNOWN')
C      WRITE(*,*)A
C      READ(*,*)
C
C     Définition des variables
C     ------------------------
      ZERO = 0.D 00
      TOL  = EPS*EPS
      PREC = TOL*1.D-06
C
      ZMOD = 1.0D0
      TAU  = ZERO
C
      ITER  = 0
      ITER2 = 0
      ICONJ = 0
C
      MAX=N*100
      IF(METH.EQ.1) MAX=N*2
C
C     Affichage du titre
C     ------------------
C      WRITE (6,200)
C
C     Initialisation de la direction de recherche
C     -------------------------------------------
      DO I=1,N
         Z(I)=ZERO
         ISA(I)=0
      ENDDO
C
C     ---------------------------------------------------------
C                      Boucle des itérations
C     ---------------------------------------------------------
C
   2  CONTINUE
C
C        Calcul du gradient et mise à jour de f(x)
C        Projection du gradient (si nécessaire)
C        -----------------------------------------
         CALL TLVECT (A,X,G,N)
         FCT=F0+DOTPRO(X,G,N)/2.-DOTPRO(X,B,N)
         DO I=1,N
            G(I)=G(I)-B(I)
         ENDDO
C
         IF(ICONST.EQ.1) THEN
            DO I=1,N
               IF(X(I).LT.EPS) THEN
                  IF (iass.EQ.1) G(I)=ZERO
                  IF ((iass.EQ.0).AND.(G(i).GT.0)) G(I)=ZERO
                  IF (iass.EQ.2) THEN
                     IF(ITER2.NE.NCHECK) THEN
                         G(i)=ZERO
                     ELSE
                        IF (G(i).GT.0) THEN
                           G(i)=ZERO
                        ENDIF
                        ITER2=0
                     ENDIF
                  ENDIF
                  IF(ISA(I).EQ.0) ICONJ=0
                  ISA(I)=1
C                  WRITE(*,202)I
               ELSE
                  ISA(I)=0
               ENDIF
            ENDDO
         ENDIF
C
C        Calcul de la norme du gradient  (=CONV)
C        Sauvegarde de l'ancienne valeur (=BR)
C        (utile uniquement pour CG)
C        ---------------------------------------
         BR=ZMOD
         ZMOD=DOTPRO(G,G,N)
         CONV=DSQRT(ZMOD)
C
C         WRITE (6,201) ITER,FCT,CONV,X(1),X(2),Z(1),Z(2),TAU
C
C        Sauvegarde des valeurs
C        ----------------------
C         WRITE(1,*)'FCT(',ITER+1,')=',FCT,';'
C         WRITE(1,*)'G(',ITER+1,')=',CONV,';'
C         WRITE(1,*)'TAU(',ITER+1,')=',TAU,';'
C         DO i=1,N
C            WRITE(1,*)'X(',i,',',ITER+1,')=',X(i),';'
C            WRITE(1,*)'Z(',i,',',ITER+1,')=',Z(i),';'
C         ENDDO
C
         ITER=ITER+1
         ITER2=ITER2+1
C
C        Teste la convergence
C        --------------------
         IF(ITER.GT.MAX) GOTO 99
C
         IF(ICONST.EQ.0) THEN
            IF(ZMOD.LT.TOL) GOTO 99
         ELSE
            IF(ZMOD.LT.TOL) THEN
               CALL TLVECT (A,X,G,N)
               DO i=1,N
                  G(i)=G(i)-B(i)
                  IF (G(i).GT.ZERO) G(i)=ZERO
               ENDDO
               ZMOD=DOTPRO(G,G,N)
               IF (ZMOD.LT.TOL) GOTO 99
               ICONJ=0
            ENDIF
         ENDIF
C
C        Calcul de GAM (-> dir. de recherche)
C        ------------------------------------
         GAM=ZMOD/BR
         IF(ICONJ.EQ.0) GAM=ZERO
         IF(METH.EQ.0) GAM=ZERO
         ICONJ=1
C
C        Mise à jour de la direction de recherche
C        ----------------------------------------
         DO 6 I=1,N
   6        Z(I)=-G(I)+GAM*Z(I)
C
C        Proj. orthog. de la dir. de recherche sur les
C        contraintes actives
C        Calcul de TAU_MAX (pas max. admissible)
C        ---------------------------------------------
         IF(ICONST.EQ.1) THEN
            NB_INT=0
            DO i=1,N
               IF((Z(i).LT.ZERO)) THEN
                  IF(X(i).LT.EPS) THEN
                     Z(i)=ZERO
                  ELSE
                     TAU=-X(i)/Z(i)
                     IF((TAU.LT.TAU_MAX).OR.(NB_INT.EQ.0))
     #                  TAU_MAX=TAU
                     NB_INT=NB_INT+1
                  ENDIF
               ENDIF
            ENDDO
            IF(DOTPRO(Z,Z,N).LT.TOL) GOTO 99
         ENDIF
C
C        Calcul de TAU non contraint
C        ---------------------------
         CONV=DOTPRO(Z,G,N)
         CALL TLVECT (A,Z,G,N)
         TEST=DOTPRO (Z,G,N)
         IF(TEST.LT.PREC) TEST=PREC
         TAU=-CONV/TEST
C
C        Choix du pas (le minimum)
C        -------------------------
         IF((NB_INT.NE.0).AND.(ICONST.EQ.1))
     #      TAU=DMIN1(TAU,TAU_MAX)
C         READ(*,*)
C
C        Calcul du nouveau point
C        -----------------------
         DO 10 I=1,N
            X(I)=X(I)+TAU*Z(I)
  10        IF(X(I).LT.EPS) X(I)=0.0D0
      GOTO 2
C
C  99  CLOSE(UNIT=1)
C
  99   WRITE(*,*)'No it:',ITER
       RETURN
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 200  FORMAT(/' IT   FUNCTION        |G|       X(1)       X(2)',
     *       '       Z(1)       Z(2)       TAU'/1X,79(1H-))
 201  FORMAT(I3,7F11.3)
 202  FORMAT(' contrainte #', I3,' active')
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      END


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE SMOGS (MXND, XN, YN, NXL, LXN, NNN, NNNOLD, NIT, EPS,
     &   RO)
C***********************************************************************

C  SUBROUTINE SMOGS  =  MESH SMOOTHING BY LAPLACE-S USING GAUSS-SEIDEL

C***********************************************************************

C  VARIABLES USED:
C     NIT   =  THE MAX NUMBER OF ITERATIONS TO DO.
C     EPS   =  MINIMUM DISTANCE NODES MUST MOVE TO CONTINUE ITERATIONS
C     RO    =  AN UNDER- OR OVER-RELAXATION FACTOR (NORMALLY 1.0)

C***********************************************************************

      DIMENSION LINES(20)
      DIMENSION LXN(4, MXND), NXL(2, 3*MXND), XN(MXND), YN(MXND)

      LOGICAL BIG, ERR

      IF (RO .LT. 0.01) RO = 1.
      EPS2 = (EPS*RO)**2

C  ITERATION LOOP

      DO 120 IT = 1, NIT
         BIG = .FALSE.

C  NODE LOOP

         DO 110 NODE = NNNOLD + 1, NNN

C  SKIP CONTINUATION AND BOUNDARY LINES

            IF ((LXN(1, NODE) .GT. 0) .AND. (LXN(2, NODE) .GT. 0)) THEN

C  SUM COORDINATES OF ALL NEIGHBORING NODES

               SUMX = 0.0
               SUMY = 0.0
               CALL GETLXN (MXND, LXN, NODE, LINES, KOUNT, ERR)

C  IGNORE ERR BECAUSE IT IS ALREADY TAKEN CARE OF IN THE SKIP

               DO 100 IL = 1, KOUNT
                  L = LINES(IL)
                  IM = NXL(1, L) + NXL(2, L) - NODE
                  SUMX = SUMX + XN(IM)
                  SUMY = SUMY + YN(IM)
  100          CONTINUE

C  REDEFINE THIS NODE - S COORDINATES

               SUMX = SUMX/DBLE(KOUNT)
               SUMY = SUMY/DBLE(KOUNT)
               XDEL = RO*(SUMX - XN(NODE))
               YDEL = RO*(SUMY - YN(NODE))
               XN(NODE) = XN(NODE) + XDEL
               YN(NODE) = YN(NODE) + YDEL

C  CHECK FOR CONVERGENCE

               IF ((XDEL*XDEL + YDEL*YDEL) .GT. EPS2) BIG = .TRUE.
            ENDIF
  110    CONTINUE

C  IF NO SIGNIFICANT MOVEMENTS OCCURRED,  RETURN

         IF (.NOT.BIG) RETURN
  120 CONTINUE
      RETURN
      END


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module provides functions for viscoelastic calculation
module mViscoElastic
  use hecmw_util
  use mMaterial
  implicit none

  private :: hvisc, trs, trsinc

contains

  !> Compute integration factor for viscoelastic material: H_visc(x) = [ 1 - exp(-x)]/x
  real(kind=kreal) function hvisc(x,expx)
    real(kind=kreal), intent(in) :: x       !< x
    real(kind=kreal), intent(in) :: expx    !< exp(-x)

    if(x < 1.d-04) then

      hvisc = 1.d0 - 0.5d0*x*(1.d0 - x/3.d0*(1.d0     &
        - 0.25d0*x*(1.d0 - 0.2d0*x)))

    else

      hvisc = (1.d0 - expx)/x

    endif

  end function

  !> Compute trs time increment
  real(kind=kreal) function trsinc(tn1,tn,mtype, mvar)
    real(kind=kreal), intent(in) :: tn1     !< temperature at time n+1
    real(kind=kreal), intent(in) :: tn      !< temperature at time n
    integer, intent(in)          :: mtype   !< material type
    real(kind=kreal), intent(in) :: mvar(:) !< material properties

    real(kind=kreal)  ::  hsn1, hsn, asn1, asn

    if(mtype==VISCOELASTIC+2) then   ! Arrhenius

      hsn = -mvar(2)*( 1.d0/(tn-mvar(3))-1.d0/(mvar(1)-mvar(3)) )/mvar(4)
      hsn1 = -mvar(2)*( 1.d0/(tn1-mvar(3))-1.d0/(mvar(1)-mvar(3)) )/mvar(4)

    else   ! WLF

      if( mvar(3)+tn1-mvar(1)<=0.d0 ) then
        trsinc= -1.d0; return
      endif
      if( mvar(3)+tn-mvar(1)<=0.d0 ) then
        trsinc= -1.d0; return
      endif
      hsn = mvar(2)*( tn-mvar(1) )/ (mvar(3)+tn-mvar(1) )*dlog(10.d0)
      hsn1 = mvar(2)*( tn1-mvar(1) )/ (mvar(3)+tn1-mvar(1) )*dlog(10.d0)

    endif

    if( dabs(hsn1-hsn)<1.d-5 ) then
      trsinc = dexp((hsn1+hsn)*0.5d0)
    else
      asn1 = dexp(hsn1)
      asn = dexp(hsn)
      trsinc = (asn1-asn)/(hsn1-hsn)
    endif

  end function

  !> Compute trs time
  real(kind=kreal) function trs(tn,mtype, mvar)
    real(kind=kreal), intent(in) :: tn      !< temperature at current step
    integer, intent(in)          :: mtype   !< material type
    real(kind=kreal), intent(in) :: mvar(:) !< material properties

    real(kind=kreal)  ::  hsn

    if(mtype==VISCOELASTIC+2) then   ! Arrhenius
      hsn = mvar(2)*( 1.d0/(tn-mvar(3))-1.d0/(mvar(1)-mvar(3)) )/mvar(4)
    else   ! WLF
      hsn = mvar(2)*( tn-mvar(1) )/ (mvar(3)+tn-mvar(1) )*dlog(10.d0)
    endif

    trs = dexp(hsn)

  end function

  !-------------------------------------------------------------------------------
  !> This subroutine calculates tangent moduli for isotropic viscoelastic material
  !-------------------------------------------------------------------------------
  subroutine calViscoelasticMatrix(matl, sectType, dt, D, temp)
    use m_ElasticLinear
    type( tMaterial ), intent(in) :: matl      !< material properties
    integer, intent(in)           :: sectType  !< not used currently
    real(kind=kreal), intent(in)  :: dt        !< time increment
    real(kind=kreal), intent(out) :: D(:,:)    !< constitutive relation
    real(kind=kreal), optional    :: temp      !> temprature

    integer   i,j, n
    real(kind=kreal) :: G,Gg,K,Kg, gfac,exp_n,mu_0,mu_n,dq_n,dtau
    real(kind=kreal) :: ina(1), outa(2), EE, PP, ddt

    type(tTable), pointer  :: dicval
    logical :: ierr

    D(:,:)=0.d0
    if( dt==0.d0 ) then
      if( present( temp ) ) then
        call calElasticMatrix( matl, D3, D, temp  )
      else
        call calElasticMatrix( matl, D3, D )
      endif
      return
    endif

    ddt = dt
    if( present(temp) ) then
      ina(1) = temp
      call fetch_TableData( MC_ISOELASTIC, matl%dict, outa, ierr, ina )
      if( ierr ) then
        EE = matl%variables(M_YOUNGS)
        PP = matl%variables(M_POISSON)
      else
        EE = outa(1)
        PP = outa(2)
      endif
      if( matl%mtype>VISCOELASTIC ) ddt=trs(temp,matl%mtype, matl%variables)*dt
    else
      EE = matl%variables(M_YOUNGS)
      PP = matl%variables(M_POISSON)
    endif

    !     Set elastic parameters for G (mu) and lambda

    G = EE/(2.d0*(1.d0 + PP))
    K = EE/(3.d0*(1.d0 - 2.d0*PP))

    !     Set properties for integrating the q_i terms

    mu_0 = 0.0d0
    gfac = 0.0d0

    call fetch_Table( MC_VISCOELASTIC, matl%dict, dicval, ierr )
    if( ierr ) stop "Viscoelastic properties not defined"

    do n = 1,dicval%tbrow
      mu_n  = dicval%tbval(1,n)
      dtau  = ddt/dicval%tbval(2,n)
      exp_n = dexp(-dtau)

      dq_n = mu_n * hvisc(dtau,exp_n)
      gfac = gfac + dq_n
      mu_0 = mu_0 + mu_n

    end do

    mu_0 = 1.d0 - mu_0
    gfac = gfac + mu_0

    !    Set tangent parameters
    Gg = G*gfac
    Kg = K - 0.6666666666666666d0*Gg
    do j =1,3
      do i = 1,3
        D(i,j) = Kg
      end do
      D(j,j) = D(j,j) + 2.d0*Gg
    end do

    do i = 4,6
      D(i,i) = Gg
    end do

  end subroutine

  !-------------------------------------------------------------------------------
  !> This subroutine provides to update stress for viscoelastic material
  subroutine UpdateViscoelastic(matl, sectType, eps, sig, vsig, dt, temp, tempn)
    use m_ElasticLinear
    type( tMaterial ), intent(in)   :: matl      !< material properties
    integer, intent(in)             :: sectType  !< not used currently
    real(kind=kreal), intent(in)    :: eps(6)    !< strain after this step
    real(kind=kreal), intent(out)   :: sig(6)    !< stress
    real(kind=kreal), intent(inout) :: vsig(:)   !< Visco stress components
    real(kind=kreal), intent(in)    :: dt        !< time increment
    real(kind=kreal), optional      :: temp      !> current temprature
    real(kind=kreal), optional      :: tempn     !> temperature at last step

    integer   i,j, n
    real(kind=kreal) :: G,Gg,K,Kg,Kth, exp_n,mu_0,mu_n,dq_n,dtau, theta
    real(kind=kreal) :: ina(1), outa(2), EE, PP, ddt

    real(kind=kreal) :: devstrain(6), en(6), D(6,6)
    type(tTable), pointer  :: dicval
    logical :: ierr

    ddt = dt
    if( present(temp) ) then
      ina(1) = temp
      call fetch_TableData( MC_ISOELASTIC, matl%dict, outa, ierr, ina )
      if( ierr ) then
        EE = matl%variables(M_YOUNGS)
        PP = matl%variables(M_POISSON)
      else
        EE = outa(1)
        PP = outa(2)
      endif
      if( matl%mtype>VISCOELASTIC ) ddt=trsinc(temp,tempn, matl%mtype, matl%variables)*dt
      if( ddt<=0.d0 ) then
        call calElasticMatrix( matl, sectType, D, temp  )
        sig = matmul( D(:,:), eps(:) )
        vsig = 0.d0
        return
      endif
    else
      EE = matl%variables(M_YOUNGS)
      PP = matl%variables(M_POISSON)
    endif

    !     Set elastic parameters for G (mu) and lambda

    G = EE/(2.d0*(1.d0 + PP))
    K = EE/(3.d0*(1.d0 - 2.d0*PP))

    !     Compute volumetric strain and deviatoric components

    theta = (eps(1) + eps(2) + eps(3))/3.d0
    do i = 1,3
      devstrain(i) = eps(i) - theta
    end do
    do i = 4,6
      devstrain(i) = eps(i)*0.5d0
    end do

    !     Set properties for integrating the q_i terms

    sig(:) = 0.0d0
    mu_0 = 0.0d0

    call fetch_Table( MC_VISCOELASTIC, matl%dict, dicval, ierr )
    if( ierr ) stop "Viscoelastic properties not defined"

    en(:) = vsig(12*dicval%tbrow+1:12*dicval%tbrow+6)

    do n = 1,dicval%tbrow
      mu_n  = dicval%tbval(1,n)
      dtau  = ddt/dicval%tbval(2,n)
      exp_n = dexp(-dtau)

      dq_n = mu_n * hvisc(dtau,exp_n)
      mu_0 = mu_0 + mu_n

      do i = 1,6
        vsig((n-1)*12+i+6) = exp_n*vsig((n-1)*12+i) + dq_n*(devstrain(i) - en(i))
        sig(i)  = sig(i) + vsig((n-1)*12+i+6)
      end do
    end do

    !     Finish stress update

    mu_0 = 1.d0 - mu_0
    do i = 1,6
      sig(i) = 2.d0*G*(mu_0*devstrain(i) + sig(i))
    end do

    !     Add elastic bulk term

    Kth = K*theta*3.0d0
    do i = 1,3
      sig(i) = sig(i) + Kth
    end do

  end subroutine

  !> Update viscoplastic state
  subroutine updateViscoElasticState( gauss )
    use mMechGauss
    type(tGaussStatus), intent(inout) :: gauss  ! status of curr gauss point

    integer :: i, n, nrow
    real(kind=kreal) :: thetan, vstrain(6)
    nrow = fetch_TableRow( MC_VISCOELASTIC, gauss%pMaterial%dict )
    do n = 1,nrow
      do i = 1,6
        gauss%fstatus((n-1)*12+i) = gauss%fstatus((n-1)*12+i+6)
      end do
    end do
    vstrain = gauss%strain
    thetan = (vstrain(1) + vstrain(2) + vstrain(3))/3.d0
    do i = 1,3
      gauss%fstatus(nrow*12+i) = vstrain(i) - thetan
    end do
    do i = 4,6
      gauss%fstatus(nrow*12+i) = vstrain(i)*0.5d0
    end do
  end subroutine

end module


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!
!     author: Yannick Muller
!
      subroutine machpi (MACH, PI,kappa, rgas)
!
!-----------------------------------------------------------------------
!                                                                      |
!     Dieses Unterprogramm berechnet die Mach-Zahl fuer das            |
!     eingegebene Druckverhaeltnis PI.                                 |
!                                                                      |
!     Eingabe-Groessen:                                                |
!       PI     = Druckverhaeltnis PS/PT                                |
!                                                                      |
!     Ausgabe-Groessen:                                                |
!       MACH   = Mach-Zahl                                             |
!                                                                      |
!-----------------------------------------------------------------------
!
      IMPLICIT CHARACTER*1 (A-Z)
      real*8    PI, MACH, MA2, kappa, rgas, kappam,kappax,pikrit
!
!-----------------------------------------------------------------------
!
      kappax = (kappa-1)/kappa
      KAPPAM = 2.d0 / (KAPPA - 1.d0)
      PIKRIT = (2.d0/(KAPPA+1.d0)) ** (KAPPA/(KAPPA-1.d0))
!
      IF (PI.GE.1.d0) THEN
!       Druckverhaeltnis groesser gleich 1
        MACH = 0.d0
      ELSEIF (PI.GT.PIKRIT) THEN
!       Druckverhaeltnis unterkritisch
        MA2  = KAPPAM * (PI**(-KAPPAX) - 1.d0)
        IF (MA2.GT.0.d0) THEN
          MACH = SQRT (MA2)
        ELSE
          MACH = 0.d0
        ENDIF
      ELSEIF (PI.GT.0.d0) THEN
!       Druckverhaeltnis ueberkritisch
        MACH = 1.d0
      ELSE
!       Druckverhaeltnis ungueltig
        MACH = 1.d20
      ENDIF
!
      RETURN
      END
!


       PROGRAM ENIAC
C      Emulate the first successful numerical weather prediction.
C      It was run on the ENIAC during 1948 and 1949.
C      The results and method were written up in Tellus 2, p. 237 1950.
C      Robert Grumbine 2 May 1995

C      Non-dimensional constants
      INTEGER p, q, n, ip, jp
      PARAMETER (p = 18)
      PARAMETER (q = 15)
      PARAMETER (n = 24)
      PARAMETER (ip = 9)
      PARAMETER (jp = 13)

C      Declare Dimensional Constants
      REAL g, radius, omega, ds, dt
      PARAMETER (g      = 9.81)
      PARAMETER (radius = 6.37E6)
      PARAMETER (omega  = 7.292E-5)
      PARAMETER (ds     = 7.36E5)
      PARAMETER (dt     = omega*86400/n)

C      Rescale feet (input dimension of Z's) to meters
      REAL fttom
      PARAMETER (fttom = 3.048)
      REAL pi
      PARAMETER (pi = 3.141592654)

C     Declare temporary arrays -
C       These were used because of the memory constraint on the ENIAC
      REAL s(0:p,0:p), t(0:q,0:q), v(0:p,0:q)
      REAL r(0:p,0:q), f(0:p,0:q), h(0:p,0:q)
      REAL a(0:p,0:q), b(0:p,0:q)
      REAL alpha(0:p,0:q), beta(0:p,0:q)
      REAL zp(0:p,0:q), zetap(0:p,0:q)

C      Declare data, physical info.
      REAL z(0:p,0:q), zeta(0:p,0:q), eta(0:p,0:q)

C      Declare computational variables
      INTEGER i, j, k, l, m

C***********************************************************!!
C      Set up the initial conditions deck
      DATA (z(0,j),j=0,15) /910, 899, 900, 885, 880, 890, 895,
     1 885, 895, 920, 910, 890, 870, 860, 850, 840/
      DATA (z(1,j),j=0,15) /907, 900, 895, 880, 870, 885, 890,
     1 890, 900, 925, 920, 900, 880, 870, 840, 830/
      DATA (z(2,j),j=0,15) /905, 901, 890, 877, 865, 865, 880,
     1 885, 900, 920, 930, 910, 885, 860, 820, 800/
      DATA (z(3,j),j=0,15) /908, 901, 888, 870, 847, 830, 830,
     1 850, 890, 900, 900, 890, 860, 800, 760, 720/
      DATA (z(4,j),j=0,15) /910, 905, 888, 871, 840, 790, 760,
     1 780, 860, 865, 830, 800, 750, 720, 680, 680/
      DATA (z(5,j),j=0,15) /915, 910, 898, 880, 850, 795, 740,
     1 740, 800, 830, 770, 720, 685, 670, 670, 670/
      DATA (z(6,j),j=0,15) /918, 919, 915, 900, 865, 810, 750,
     1 730, 750, 740, 730, 690, 655, 665, 665, 665/
      DATA (z(7,j),j=0,15) /930, 931, 926, 915, 883, 825, 770,
     1 725, 700, 680, 670, 660, 660, 655, 655, 660/
      DATA (z(8,j),j=0,15) /932, 945, 942, 932, 900, 850, 780,
     1 720, 660, 610, 600, 620, 640, 650, 655, 665/
      DATA (z(9,j),j=0,15) /935, 950, 950, 942, 924, 890, 800,
     1 710, 640, 600, 590, 580, 600, 645, 660, 675/
      DATA (z(10,j),j=0,15) /933, 940, 945, 942, 926, 890, 810,
     1 720, 650, 600, 580, 560, 620, 655, 670, 685/
      DATA (z(11,j),j=0,15) /931, 934, 939, 935, 897, 880, 830,
     1 750, 690, 620, 600, 600, 630, 670, 685, 700/
      DATA (z(12,j),j=0,15) /925, 926, 925, 920, 890, 865, 830,
     1 760, 710, 670, 620, 620, 650, 690, 700, 710/
      DATA (z(13,j),j=0,15) /920, 919, 896, 903, 875, 845, 810,
     1 760, 735, 730, 710, 720, 720, 740, 730, 730/
      DATA (z(14,j),j=0,15) /915, 913, 889, 897, 860, 825, 790,
     1 780, 790, 830, 840, 850, 820, 780, 760, 740/
      DATA (z(15,j),j=0,15) /912, 910, 885, 891, 860, 830, 820,
     1 840, 860, 890, 900, 900, 850, 790, 770, 755/
      DATA (z(16,j),j=0,15) /908, 908, 885, 900, 880, 870, 880,
     1 890, 910, 925, 920, 900, 870, 800, 780, 765/
      DATA (z(17,j),j=0,15) /905, 907, 886, 905, 890, 900, 910,
     1 920, 920, 920, 900, 890, 870, 840, 800, 780/
      DATA (z(18,j),j=0,15) /903, 906, 886, 910, 900, 920, 920,
     1 925, 915, 910, 890, 880, 860, 850, 820, 810/
C***********************************************************!!

C      BEGIN THE EXECUTION HERE
C      This file is not comparable to anything in the original program.
      OPEN (UNIT=1, FILE="ENIAC.OUT", FORM="FORMATTED")

C      Rescale the heights to metric
      DO 1 j = 0, 15
        DO 2 i = 0, 18
          z(i,j)  = z(i,j)/fttom
    2   CONTINUE
    1 CONTINUE

      zeta = 0.0

C      Prepare the data decks - used due to memory constraints
      DO 10 i = 1, p-1
        DO 11 l = 1, p-1
          s(l,i) = SIN(pi*i*l/p)
   11   CONTINUE
   10 CONTINUE

      DO 20 j = 1, q-1
        DO 21 m = 1, q-1
          t(m,j) = SIN(pi*m*j/q)
   21   CONTINUE
   20 CONTINUE

      DO 30 i = 0, p
        DO 31 j = 0, q
          v(i,j) = p*q*(SIN(pi*i/(2*p))**2
     1                + SIN(pi*j/(2*q))**2 )
   31   CONTINUE
   30 CONTINUE

      DO 40 i = 0, p
        DO 41 j = 0, q
          r(i,j) = (ds/(2*radius))**2
     1           *((i-ip)**2+(j-jp)**2)
   41   CONTINUE
   40 CONTINUE

      DO 50 i = 0, p
        DO 51 j = 0, q
          f(i,j) = (1.-r(i,j))/(1.+r(i,j))
   51   CONTINUE
   50 CONTINUE

      DO 60 i = 0, p
        DO 61 j = 0, q
          h(i,j) = g/(2*omega*ds)**2
     1          * (1+r(i,j))**3/(1.-r(i,j))
   61   CONTINUE
   60 CONTINUE

      DO 70 i = 1, p-1
        DO 71 j = 1, q-1
          zeta(i,j) = z(i+1,j)+z(i,j+1)+z(i-1,j)+z(i,j-1)
     1                - 4.*z(i,j)
   71   CONTINUE
   70 CONTINUE

      DO 72 j = 0, q
        zeta(0,j) = 2.*zeta(1,j)  - zeta(2,j)
        zeta(p,j) = 2.*zeta(p-1,j)- zeta(p-2,j)
   72 CONTINUE
      DO 73 i = 0,p
        zeta(i,0) = 2.*zeta(i,1)   - zeta(i,2)
        zeta(i,q) = 2.*zeta(i,q-1) - zeta(i,q-2)
   73 CONTINUE

      DO 80 j = 0, q
        DO 81 i = 0, p
          eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
   81   CONTINUE
   80 CONTINUE

      PRINT *,SECOND()*1000.,' ms'
C     END OF THE PRELIMINARY SET UP SECTION
C***********************************************************!!
C      BEGIN THE ITERATIVE SOLUTION OF THE EQUATIONS
      DO 2000 k = 0, 3*n-1

      DO 1010 j = 1, q-1
        DO 1020 i = 1, p-1
          eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
 1020   CONTINUE
 1010 CONTINUE

      DO 1101 i = 1, p-1
        j = 0
        IF (z(i+1,0) .LT. z(i-1,0)) THEN
          eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
        ENDIF
        j = q
        IF (z(i+1,q) .GT. z(i-1,q)) THEN
          eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
        ENDIF
 1101 CONTINUE

      DO 1111 j = 1, q-1
        i = 0
        IF (z(0,j+1).GT.z(0,j-1)) THEN
          eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
        ENDIF
        i = p
        IF (z(p,j+1).LT.z(p,j-1)) THEN
          eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
        ENDIF
 1111 CONTINUE

       DO 1200 j = 1, q-1
        DO 1210 i = 1, p-1
          zetap(i,j) = 0.5*( (eta(i+1,j)-eta(i-1,j))
     1                        *(z(i,j+1)-z(i,j-1))
     2                   -   (eta(i,j+1)-eta(i,j-1))
     3                        *(z(i+1,j)-z(i-1,j)) )
 1210   CONTINUE
 1200 CONTINUE

       DO 1300 j = 1, q-1
        DO 1310 i = 1, p-1
          alpha(i,j) = 0.0
          DO 1320 l = 1, p-1
            alpha(i,j)=alpha(i,j)+s(l,i)*zetap(l,j)
 1320     CONTINUE
 1310   CONTINUE
 1300 CONTINUE

       DO 1400 j = 1, q-1
        DO 1410 i = 1, p-1
          a(i,j) = 0.0
          DO 1420 m = 1, q-1
            a(i,j) = a(i,j) + t(m,j)*alpha(i,m)
 1420     CONTINUE
 1410   CONTINUE
 1400 CONTINUE

       DO 1500 j = 1, q-1
        DO 1510 i = 1, p-1
          b(i,j) = -a(i,j)/v(i,j)
 1510   CONTINUE
 1500 CONTINUE

      DO 1600 j = 1, q-1
        DO 1610 i = 1, p-1
          beta(i,j) = 0.0
          DO 1620 m = 1, q-1
            beta(i,j) = beta(i,j)+t(m,j)*b(i,m)
 1620     CONTINUE
 1610   CONTINUE
 1600 CONTINUE

       DO 1700 j = 1, q-1
        DO 1710 i = 1, p-1
          zp(i,j) = 0.0
          DO 1720 l = 1, p-1
            zp(i,j) = zp(i,j)+s(l,i)*beta(l,j)
 1720     CONTINUE
 1710   CONTINUE
 1700 CONTINUE

C      SECTION FOR CARRYING FORWARD THE EXTRAPOLATION
       IF (k.EQ.0) THEN
        DO 1800 j= 1, q-1
          DO 1810 i = 1, p-1
            z(i,j)    = z(i,j)+dt*zp(i,j)
            zeta(i,j) = zeta(i,j)+dt*zetap(i,j)
 1810     CONTINUE
 1800   CONTINUE
        ELSE
        DO 1820 j = 1, q-1
          DO 1830 i = 1, p-1
            z(i,j)    = z(i,j)+2.*dt*zp(i,j)
            zeta(i,j) = zeta(i,j)+2.*dt*zetap(i,j)
 1830     CONTINUE
 1820   CONTINUE
      ENDIF

C      Apply the inflow/outflow conditions
      DO 1900 j = 1, q-1
        IF (z(0,j+1) .GT. z(0,j-1)) THEN
          z(0,j)    = z(0,j)
          zeta(0,j) = 2.*zeta(1,j)-zeta(2,j)
         ELSE
          z(0,j)    = z(0,j)
          zeta(0,j) = zeta(0,j)
        ENDIF
        IF (z(p,j+1) .LT. z(p,j-1)) THEN
          z(p,j)    = z(p,j)
          zeta(p,j) = 2.*zeta(p-1,j)-zeta(p-2,j)
         ELSE
          z(p,j)    = z(p,j)
          zeta(p,j) = zeta(p,j)
        ENDIF
 1900 CONTINUE
       DO 1910 i = 1, p-1
        IF (z(i+1,0) .LT. z(i-1,0)) THEN
           z(i,0)    = z(i,0)
          zeta(i,0) = 2.*zeta(i,1)-zeta(i,2)
         ELSE
          z(i,0)    = z(i,0)
          zeta(i,0) = zeta(i,0)
        ENDIF
        IF (z(i+1,q) .GT. z(i-1,q)) THEN
          z(i,q)    = z(i,q)
          zeta(i,q) = 2.*zeta(i,q-1)-zeta(i,q-2)
        ENDIF
 1910 CONTINUE

CD      WRITE (*,9003) k
CD      WRITE (*,9001) ((z(i,j),j=0,q),i=0,p)
CD      WRITE (*,9002)
      WRITE (1,9003) k
      WRITE (1,9001) ((z(i,j),j=0,q),i=0,p)
      WRITE (1,9002)
 9001 FORMAT (16F7.2)
 9002 FORMAT (' ')
 9003 FORMAT ('k = ',I3)

 2000 CONTINUE
      PRINT *,SECOND()*1000.,' ms'

C***********************************************************!!

      END


      implicit double precision (a-h,o-z)
c
c             make SSY boundary displacements for K and T loading.
c             also scale existing coords to a different radius
c             if desired.
c
c
      dimension coord(3,5000), node_list(5000)
      double precision new_radius
      integer elem, outfile
      character * 80 fname, text * 1
c
      write(*,*) ' '
      write(*,*) '>> Compute applied displacements matching K & T'
      write(*,*) ' '
      write(*,*) ' > Coordinate file name: '
      read(*,fmt='(a80)') fname
      infile = 10
      open(unit=infile,file=fname,status='old')
      write(*,*)
     &   ' > Final K(I), T/sig-o, sig-o, number of load steps: '
      read(*,*) final_k, t_ratio, sig_o, num_steps
      applied_k = final_k / real(num_steps)
      applied_t = sig_o * t_ratio / real(num_steps)
      write(*,*) ' > Start radius, new scaled radius: '
      read(*,*) start_radius, new_radius
c
      read(infile,*) nnode
      do node = 1, nnode
       read(infile,*) ii, x, y, z
       x = x * (new_radius/start_radius)
       y = y * (new_radius/start_radius)
       coord(1,node) = x
       coord(2,node) = y
       coord(3,node) = z
      end do
      write(*,*) ' >> data file read'
c
c             loop to find all nodes on the outer most surface, i.e.,
c             those with radius.
c
      do node = 1, 5000
       node_list(node) = 0
      end do
c
      tolerance = 0.01
      node_count = 0
      do node = 1, nnode
       x = coord(1,node)
       y = coord(2,node)
       r = abs( sqrt( x*x + y*y ) - new_radius )
       if ( r .le. tolerance ) then
          node_count = node_count + 1
          node_list(node) = 1
       end if
      end do
      write(*,*) '>> Number of nodes on boundary: ',
     &          node_count
c
c             nodes to process have been marked in list.
c
      rnu = 0.3
      e = 30000.0
      pi = 3.14159
      open(unit=10,file='constraints',status='unknown')
      open(unit=11,file='new_coords',status='unknown')
      outfile = 10
      do node = 1, nnode
       x = coord(1,node)
       y = coord(2,node)
       if ( node_list(node) .eq. 1 ) then
            x = coord(1,node)
            y = coord(2,node)
            r = sqrt(x*x+y*y)
            theta = atan2( y, x )
            ct2 = cos(theta*0.5)
            st2 = sin(theta*0.5)
            ct  = cos(theta)
            st  = sin(theta)
            term1 = (3.0-4.0*rnu-ct) * ct2
            term2 = (3.0-4.0*rnu-ct) * st2
            term3 = sqrt( r * 0.5 / pi )
            term4 = (1.0 + rnu ) * applied_k / e
            u_k = term4 * term3 * term1
            v_k = term4 * term3 * term2
            u_t = (1.0-rnu*rnu) * applied_t * ct * r / e
            v_t = -rnu *(1.0+rnu) * applied_t * st * r / e
            u_total = u_k + u_t
            v_total = v_k + v_t
            write(outfile,1000) node, u_total, v_total
        end if
       write(11,1100) node, x, y, coord(3,node)
      end do
c
      close(unit=10)
      close(unit=11)
      write(*,*) '.. new coordinates is file: coords'
      write(*,*) '.. K and T constraints in file: constraints'
c
 1000 format(4x,i5,' u  ',e16.8,' v ',e16.8)
 1100 format(2x,i5,3e16.8)
      stop
      end


!     =====================================================
    subroutine limiter(maxm,num_eqn,num_waves,num_ghost,mx,wave,s, &
    mthlim)
!     =====================================================

!     # Apply a limiter to the waves.
!     # The limiter is computed by comparing the 2-norm of each wave with
!     # the projection of the wave from the interface to the left or
!     # right onto the current wave.  For a linear system this would
!     # correspond to comparing the norms of the two waves.  For a
!     # nonlinear problem the eigenvectors are not colinear and so the
!     # projection is needed to provide more limiting in the case where the
!     # neighboring wave has large norm but points in a different direction
!     # in phase space.

!     # The specific limiter used in each family is determined by the
!     # value of the corresponding element of the array mthlim, as used in
!     # the function philim.
!     # Note that a different limiter may be used in each wave family.

!     # dotl and dotr denote the inner product of wave with the wave to
!     # the left or right.  The norm of the projections onto the wave are then
!     # given by dotl/wnorm2 and dotr/wnorm2, where wnorm2 is the 2-norm
!     # of wave.

    implicit double precision (a-h,o-z)
    dimension mthlim(num_waves)
    dimension wave(num_eqn, num_waves,1-num_ghost:maxm+num_ghost)
    dimension    s(num_waves,1-num_ghost:maxm+num_ghost)

    do 50 mw=1,num_waves
        if (mthlim(mw) == 0) go to 50
        dotr = 0.d0
        do 40 i = 0, mx+1
            wnorm2 = 0.d0
            dotl = dotr
            dotr = 0.d0
            do 20 m=1,num_eqn
                wnorm2 = wnorm2 + wave(m,mw,i)**2
                dotr = dotr + wave(m,mw,i)*wave(m,mw,i+1)
            20 END DO
            if (i == 0) go to 40
            if (wnorm2 == 0.d0) go to 40

            if (s(mw,i) > 0.d0) then
                wlimitr = philim(wnorm2, dotl, mthlim(mw))
            else
                wlimitr = philim(wnorm2, dotr, mthlim(mw))
            endif

            do 30 m=1,num_eqn
                wave(m,mw,i) = wlimitr * wave(m,mw,i)
            30 END DO
        40 END DO
    50 END DO

    return
    end subroutine limiter


***********************************************************************
* Classical VANCA preconditioner, SCGS method
*
* Extended calling convention
*
* This routine performs one preconditioning step
*
*    (du,dp) = Vanca(F)
*
* with the Diagonal-Vanca preconditioner. (du,dp) must be =0 initially.
* VANCP4 executes a local Block-Gauss-Seidel preconditioner onto the
* vector F to calculate a preconditioned vector (du,dp).
*
* In:
*   U1,
*   U2     - array [1..NU] of double precision
*   P      - array [1..NP] of double precision
*            Velocity and Pressure components of the preconditioned
*            vector; must be =0 initially!
*   F1,
*   F2     - array [1..NU] of double precision
*   FP     - array [1..NP] of double precision
*            Velocity and pressure components of the vector that should
*            be preconditioned.
*   A,
*   KCOLA,
*   KLDA   - Current system matrix for velocity components
*
*   B1,
*   B2,
*   KCOLB,
*   KLDB   - The two pressure matrices
*
*   NU     - Length of velocity vectors and dimension of A
*   NP     - Length of pressure vectors and dimension of B1, B2
*
*   KMBD,
*   KVERT,
*   KMID,
*   KXNPR,
*   NVT,
*   NEL    - Usual geometry information;
*            KXNPR(.) decides on Dirichlet/Neumann nodes.
*
*   RLXSM  - Relaxation parameter; 0 <= RLXSM < 1
*
* Out:
*   U1,U2,P - Preconditioned vector, velocity and pressure
***********************************************************************

      SUBROUTINE  VANCP4 (U1,U2,P,F1,F2,FP,
     *                    A,KCOLA,KLDA,B1,B2,KCOLB,KLDB,NU,NP,
     *                    KMID,KXNPR,NEL,NVT)

      IMPLICIT NONE

C common blocks

      INCLUDE 'cout.inc'

      INCLUDE 'cbasictria.inc'

C parameters

      DOUBLE PRECISION U1(*),U2(*),P(*)
      DOUBLE PRECISION F1(*),F2(*),FP(*)
      DOUBLE PRECISION A(*),B1(*),B2(*)
      INTEGER KCOLA(*),KLDA(*),KCOLB(*),KLDB(*)
      INTEGER KMID(NNVE,*),KXNPR(2,*)
      INTEGER NU,NP
      INTEGER NEL,NVT

C     Local arrays for informations about one element

      DOUBLE PRECISION AA(4),BB1(4),BB2(4),FF1(4),FF2(4)
      INTEGER IU(4)
      LOGICAL BDBC(4)

C     local variables

      INTEGER IEL,II,IMID,IA1,IA2,IA,IB,I,J,IB1,IB2,JP1,JP2
      DOUBLE PRECISION FFP,PJP,AOFF,A1,A2

C=======================================================================
C     Block Gauss-Seidel on Schur Complement
C=======================================================================

C     Basic algorithm:
C
C     What are we doing here? Well, we want to perform
C     *preconditioning*, i.e. we have to solve the problem
C
C       x_new  =  C^-1 (x_old)  =  C^-1 (F)  =  C^-1 (f,g)
C
C     for a "special" preconditioner C which we define in a moment.
C     This is equivalent to solving the system
C
C       C (x_new)  = x_old
C
C     C should be some approximation to A. Imagine our global system:
C
C         [ A   B ] (u) = (f)
C         [ B^t 0 ] (p)   (g)
C
C     In the Navier-Stokes equations with (u,p) being the preconditioned
C     vector, there should be g=0 - but this cannot be assumed
C     as it does not happen in general.
C     Now the algorithm for generating a new (u,p) vector from the old
C     one reads roughly as follows:
C
C     a) Restrict to a small part of the domain, in our case to one cell.
C     b) Fetch all the data (velocity, pressure) on that cell. On the
C        first cell, we have only "old" velocity entries. These values
C        are updated and then the calculation proceeds with the 2nd cell.
C
C               old                      new
C            |---X---|                |---X---|
C            |       |                |       |
C        old X   1   X old   -->  new X   1   X new
C            |       |                |       |
C            |---X---|                |---X---|
C               old                      new
C
C        From the second cell on, there might be "old" data and "new"
C        data on that cell - the old data that has not been updated and
C        perhaps some already updated velocity data from a neighbor cell.
C
C               new     old                   new     new
C            |---X---|---X---|             |---X---|---X---|
C            |       |       |             |       |       |
C        new X   1   X   2   X old --> new X   1   X   2   X new
C            |       |new    |             |       |newer  |
C            |---X---|---X---|             |---X---|---X---|
C               new     old                   new     new
C
C        These values are updated and then the calculation proceeds
C        with the next cell.
C        As can be seen in the above picture, the "new" node in the
C        middle is even going to be a "newer" node when handled again
C        for the 2nd cell. This is meant by "Gauss-Seldel" character:
C        Information is updated subsequently by using "old" data and
C        "new" data from a previous calculation.
C
C     So we start with a loop over all elements

      DO IEL=1,NEL

C       We now have the element
C                                            U3/V3
C       |---------|                       |----X----|
C       |         |                       |         |
C       |   IEL   |   with DOF's    U4/V4 X    P    X U2/V2
C       |         |                       |         |
C       |---------|                       |----X----|
C                                            U1/V1
C
C       Fetch the pressure P on the current element into FFP

        FFP=FP(IEL)

C       Loop over all 4 U-nodes of that element

        DO II=1,4

C         Set I to the DOF that belongs to our edge II:

          IMID = KMID(II,IEL)
          I    = IMID-NVT

C         Write the number of the edge/node to IU:

          IU(II) = I

C         Write into BDBC whether the edge is a Dirichlet-
C         Boundary edge:

          BDBC(II) = IAND(KXNPR(1,IMID),2**12).NE.0

C         Put on AA(.) the diagonal entry of matrix A

          IA1    = KLDA(I)
          AA(II) = A(IA1)

C         Set FF1/FF2 initially to the value F1/F2 of the right hand
C         side vector that belongs to our current DOF corresponding
C         to II

          FF1(II) = F1(I)
          FF2(II) = F2(I)

C         What do we have at this point?
C         FF1/FF2: "local" RHS vector belonging to the DOF's on the
C                  current element
C         AA     : Diagonal entries of A belonging to these DOF's
C         BDBC   : Whether the DOF's belong to Dirichlet nodes
C
C         And at the moment:
C         I      : number of current DOF on element IEL
C         II     : "local" number of DOF on element IEL, i.e.
C                  number of the edge
C
C         Now comes the crucial point with the "update": How to
C         subsequently update the vertex values, such that the whole
C         thing still converges to the solution, even if a node
C         is updated more than once? Here, we use a typical
C         matrix-decomposition approach:
C
C         Again consider the problem:
C
C            [ A   B ] (u) = (f)
C            [ B^t 0 ] (p)   (g)
C
C         We assume, that all components in the vector (u,p) are
C         given - except for the four velocity unknowns and the
C         pressure unknown on the current element; these five unknowns
C         are located anywhere in the (u,p) vector. The idea is to
C         shift "everything known" to the right hand side to obtain
C         a system for only these unknowns!
C
C         Extracting all the lines of the system that correspond to
C         DOF's on our single element IEL results in a rectangular
C         system of the form
C
C            [ === A^ === B~ ] (|) = (f)
C            [ B~^t       0  ] (u)   (g)
C                              (|)
C                              (p)
C
C         <=>  [ MAT1 MAT2 B~ ] (u) = (fu)
C              [    ****   0  ] (p)   (fp)
C
C         with A^ being an 4 x (2*NVT) matrix for the two velocity
C         components and B being an (2*4) x 1 matrix that couples the
C         velocities to the pressure on our current element.
C         B~ is a 8 x 2 matrix: As every velocity couples with at most
C         two pressure elements on the neighbour cell, so we have
C         2 columns in the B-matrix.
C
C                IEL                              IEL
C             |--------|             |--------|--------|
C             |        |             |        |        |
C             |   P    |      or     |   Q    X   P    |
C             |        |             |        |        |
C           --|---X----|--           |--------|--------|
C
C         Now, throw all summands to the RHS vector that do
C         not correspond to the velocity/pressure DOF's on our single
C         element IEL!
C
C         That way, A^ is reduced to a square matrix with two square
C         submatrices A~ of size 4 x 4. The 8 x 2-matrix B~ reduces to
C         two 4 x 1 submatrices (originally, every velocity couples with
C         two pressure elements on the neighbour cell, so we have
C         2 columns in the B-matrix).
C
C         The system roughly looks like:
C
C         [ ....        B1 ] (u1)   (f1)           (| )           (| )           (| )
C         [ .A~.        |  ] (u2)   (| )           (| )           (| )           (| )
C         [ ....        |  ] (u3)   (| )           (| )           (| )           (| )
C         [ ....        |  ] (u4)   (| )           (| )           (| )           (| )
C         [       ....  B2 ] (v1) = (f2) - sum u_i (ci) - sum v_i (di) - sum   Q (qi)
C         [       .A~.  |  ] (v2)   (| )   i>4     (| )   i>4     (| )  Q in N   (| )
C         [       ....  |  ] (v3)   (| )           (| )           (| )           (| )
C         [       ....  |  ] (v4)   (| )           (| )           (| )           (| )
C         [ B1^T  B2^T  0  ] (p )   (fp)           (0 )           (0 )           (0 )
C
C         assuming in the example that element IEL contains u1,u2,u3,u4,
C         v1,v2,v3,v4 and p as DOF's, and using the notation that ci
C         and di are the i th column of matrix MAT1 and MAT2 above,
C         respectively.
C         Q is the pressure on the neighbour elements in the
C         neighbourhood N of element IEL and
C         qi the corresponding column from the B~-matrix.
C
C         But we do even more! Consider the 4x4-matrix A~. This can be
C         decomposed into A~ = L+S+R with L being the lower left, R
C         being the upper right and S being the diagonal part of A~.
C         Again, throw Lu, Ru and Lv, Rv to the right hand side vector,
C         leaving alone the diagonal 4x4 matrix S on the left:
C
C         [ *           B1 ] (u1)   (d11)
C         [  *          |  ] (u2)   (d12)
C         [   *         |  ] (u3)   (d13)
C         [    *        |  ] (u4)   (d14)       [ S         B1 ] (ul)   (du)
C         [       *     B2 ] (v1) = (d21)  <=>  [      S    B2 ] (vl) = (dv)
C         [        *    |  ] (v2)   (d22)       [ B1^t B2^t  0 ] (p )   (dp)
C         [         *   |  ] (v3)   (d23)
C         [          *  |  ] (v4)   (d24)
C         [ B1^T  B2^T  0  ] (p )   (d33)
C
C         with d1k = f1k - sum  A~(k,i) u_i.
C                          i<>k
C         d2k is calculated similar. (du, dv, dp) is called
C         "local residuum".
C
C         Note: This only holds for inner edges!
C         Do we have a boundary edge?

          IF (.NOT.BDBC(II)) THEN

C           No, we have an inner edge.
C
C           Create a "local" residuum!
C           Take the original RHS and subtract all entries of "A*u" to
C           this RHS as being given. What we throw here to the RHS is
C           therefore on one hand a set of entries of the old velocities
C           as well as a set of entries which might have been calculated
C           by a previous update of another cell in our neighbourhood.

            IA2=KLDA(I+1)-1
            DO IA=IA1+1,IA2
              J=KCOLA(IA)
              AOFF=A(IA)
              FF1(II) = FF1(II)-AOFF*U1(J)
              FF2(II) = FF2(II)-AOFF*U2(J)
            END DO

C           Get BB1,BB2 and modify FF1,FF2.
C
C           In every line of each B-matrix, there is either one entry
C           (in case of boundary nodes) or there are at most two entries
C           (for inner nodes, which where each velocity component couples
C           with two elements:
C
C                IEL                              IEL
C             |--------|             |--------|--------|
C             |        |             |        |        |
C             |   P1   |      or     |   P2   X   P1   |
C             |        |             |        |        |
C           --|---X----|--           |--------|--------|
C
C           Our current edge is either an inner edge with two elements
C           attached, or a boundary edge with Neumann boundary
C           conditions.
C
C           In the case that two elements meet each other, we subtract
C           the B*(pressure of the neighbour cell) from the RHS.
C
C           In the case that we have only one element, there's
C           only one entry in the row of the B-matrix. We fetch the
C           first and last entry of the line, which will coincide
C           then (IB1=IB2). As there is no neighbour cell, we must
C           not subtract anything from the RHS! Nevertheless we have to
C           note the column numbers in the B-matrices to our BB1/BB2
C           vectors.
C
C           Get the first and last entry from row I of the B-matrices:

            IB1=KLDB(I)
            IB2=KLDB(I+1)-1
            JP1=KCOLB(IB1)
            JP2=KCOLB(IB2)

C           Check which of these two belong to the current element.
C           The corresponding other one is to be subtracted from the RHS
C           vector.

            IF (JP1.EQ.IEL)  THEN

              PJP = P(JP2)
              BB1(II) = B1(IB1)
              BB2(II) = B2(IB1)

C             Don't subtract anything from the RHS if there's
C             no neighbour element!

              IF (IB1.NE.IB2) THEN
                FF1(II) = FF1(II)-B1(IB2)*PJP
                FF2(II) = FF2(II)-B2(IB2)*PJP
              END IF

            ELSE IF (JP2.EQ.IEL)  THEN

              PJP = P(JP1)
              BB1(II) = B1(IB2)
              BB2(II) = B2(IB2)

C             Don't subtract anything from the RHS if there's
C             no neighbour element!

              IF (IB1.NE.IB2) THEN
                FF1(II) = FF1(II)-B1(IB1)*PJP
                FF2(II) = FF2(II)-B2(IB1)*PJP
              END IF

            ELSE
              WRITE (MTERM,*)
     *              'ERROR in VANCP4: IEL entry in B not found'
              STOP
            ENDIF

C           That's it, FF1/FF2 form the "local defect".

          ELSE

C           Hmmm, the edge II is a Dirichlet boundary edge.
C           That means there is no adjacent element with a pressure that
C           we have to subtract from the RHS vector.
C           Simply write the one and only element in the current line
C           of the B-matrices to BB1/BB2.

            IB = KLDB(I)
            BB1(II) = B1(IB)
            BB2(II) = B2(IB)

          END IF ! (not BDBC(II))

C         Go to the next DOF on our current element IEL...

        END DO ! II

C       Call the subroutine ELUPD2 for element update.
C
C       This routine will now "solve" the above system
C
C          [ S         B1 ] (ul)   (du)
C          [      S    B2 ] (vl) = (dv)
C          [ B1^t B2^t  0 ] (p )   (dp)
C
C       and write the new velocity/pressure values (ul,vl,p) to the
C       solution vector (U1,U2,P).
C       Note that although we called (du,dv,dp) "local defect", it's
C       not a real defect! (du,dv,dp) is the original RHS vector
C       where a lot of parts of the original system have been
C       subtracted in equivalent formulations! Therefore, the solution
C       of this local system really gives new values for velocity/
C       pressure and not "update" values like in a defect correction
C       approach!

        CALL  ELUPD2 (U1,U2,P,IEL,IU,BDBC,AA,BB1,BB2,FF1,FF2,FFP)

C       Go to the next element...

      END DO ! IEL

C=======================================================================
C
C     At this point we are finished calculating a the preconditioned
C     vector (du,dv,dp). The caller can use it e.g. in a defect
C     correction approach...

      END


!=======================================================================
!            MAKING OPACITY TABLE USING BOHREN-HUFFMAN PROGRAM
!                        ADAPTED BY B.T. DRAINE
!           MADE INTO F90 AND INTO CURRENT FORM BY C.P. DULLEMOND
!
!***********************************************************************
! COMMENTS FROM ORIGINAL CODE:
! Program to interactively call Bohren-Huffman Mie theory program
!
! CALLBHMIE will interactively prompt for:
! 1. refractive index of surrounding medium
! 2. either refractive index or dielectric constant of sphere
! 3. radius of sphere
! 4. wavelength (in vacuo)
! 5. number of angles at which to calculate scattering intensities
!
! CALLBHMIE will return:
! 1. Q_ext, Q_abs, Q_sca, g, Q_back
! 2. If NANG>0, then will also return scattering matrix elements
!    S_11, S_33, S_34, and POL
!
! Adapted by B.T.Draine, Princeton Univ. Obs.
!***********************************************************************
!=======================================================================
program bhmakeopac
  integer, parameter :: MXNANG=1000
  integer :: IREADEP,J,NAN,NANG,NANG0
  real :: AJ,ANG,DANG,GSCA,PI,POL
  real :: QABS,QBACK,QEXT,QSCA,RAD,REFMED
  real :: S11,S12,S33,S34,WAVEL,X
  complex :: REFREL,CXEPS,S1(2*MXNANG-1),S2(2*MXNANG-1)
  real, allocatable :: lambda_cm(:),optcnst_n(:),optcnst_k(:)
  real :: kappa_abs,kappa_sca,kappa_g
  real :: zscat(2*MXNANG-1,1:6)
  integer :: nlam,ilam
  real :: agrain_cm,xigrain,dum(1:3),siggeom,mgrain
  character*160 :: filename,material
  logical :: notfinished
  PI=4.E0*ATAN(1.E0)
  !
  ! Defaults
  !
  REFMED = 1.d0
  !
  ! Open parameter file
  !
  open(unit=1,file='param.inp')
  read(1,*) material
  read(1,*) agrain_cm
  read(1,*) xigrain
  read(1,*) nang0
  close(1)
  filename = trim(material)//".lnk"
  !
  ! Open optical constants file
  !
  nlam = 0
  notfinished = .true.
  open(unit=1,file=filename)
  do while(notfinished)
     read(1,*,end=20) dum
     nlam = nlam + 1
  enddo
20 continue
  close(1)
  allocate(lambda_cm(nlam),optcnst_n(nlam),optcnst_k(nlam))
  open(unit=1,file=filename)
  do ilam=1,nlam
     read(1,*) lambda_cm(ilam),optcnst_n(ilam),optcnst_k(ilam)
  enddo
  close(1)
  lambda_cm = lambda_cm * 1e-4
  !
  ! Compute geometric cross section
  !
  siggeom = pi*agrain_cm**2
  !
  ! Compute mass of grain
  !
  mgrain = (4.d0*pi/3.d0)*xigrain*agrain_cm**3
  !
  ! Open the output file
  !
  filename = 'dustkappa_'//trim(material)//'.inp'
  open(unit=1,file=filename)
  write(1,*) 3  ! Format number
  write(1,*) nlam
  !
  ! Now do the loop over wavelengths
  !
  do ilam=1,nlam
     !
     ! Prepare the parameters for BHMie
     !
     ! The complex index of refraction
     !
     refrel = cmplx(optcnst_n(ilam),optcnst_k(ilam))/refmed
     !
     ! Radius of the grain in cm
     !
     rad = agrain_cm
     !
     ! Wavelength in cm
     !
     wavel = lambda_cm(ilam)
     !
     ! Number of angles
     !
     IF(NANG0.GT.MXNANG)STOP'***Error: NANG > MXNANG'
     NANG=NANG0
     IF(NANG0.LT.2)NANG=2
     !
     ! Compute the dimensionless grain size size
     !
     X=2.E0*PI*RAD*REFMED/WAVEL
     !
     ! NANG=number of angles between 0 and 90 degrees (incl. 0 and 90)
     ! Scattering matrix elements are calculated for 2*NANG-1 angles
     ! including 0, 90, and 180 degrees.
     !
     IF(NANG.GT.1)DANG=0.5E0*PI/FLOAT(NANG-1)
     !
     ! Call BHMie
     !
     CALL BHMIE(X,REFREL,NANG,S1,S2,QEXT,QSCA,QBACK,GSCA)
     QABS=QEXT-QSCA
     !
     ! Put results into array
     !
     kappa_abs = qabs*siggeom/mgrain
     kappa_sca = qsca*siggeom/mgrain
     kappa_g   = GSCA
     write(1,*) lambda_cm(ilam)*1e4,kappa_abs,kappa_sca,kappa_g
     !
     ! Also store the Z matrix elements
     !
!     IF(NANG0.GT.1)THEN
!        NAN=2*NANG-1
!        DO J=1,NAN
!           AJ=J
!           S11=0.5E0*CABS(S2(J))*CABS(S2(J))
!           S11=S11+0.5E0*CABS(S1(J))*CABS(S1(J))
!           S12=0.5E0*CABS(S2(J))*CABS(S2(J))
!           S12=S12-0.5E0*CABS(S1(J))*CABS(S1(J))
!           POL=-S12/S11
!           S33=REAL(S2(J)*CONJG(S1(J)))
!           S34=AIMAG(S2(J)*CONJG(S1(J)))
!           ANG=DANG*(AJ-1.E0)*180.E0/PI
!           WRITE(7,6075)ANG,S11,POL,S33,S34
!           WRITE(*,6075)ANG,S11,POL,S33,S34
!        enddo
!     ENDIF
  enddo
  close(1)
  !
  ! Deallocate stuff
  !
  deallocate(lambda_cm,optcnst_n,optcnst_k)
end program bhmakeopac


MODULE m_sgml
  CONTAINS
  REAL FUNCTION sgml(l1,m1,is1,l2,m2,is2)
    USE m_juDFT
    USE m_constants
    !
    ! FUNCTION SGML ******************************************************
    !
    !      THIS FUNCTION CALCULATES ANGULAR PART OF THE MATRIX ELEMENT
    !
    !      ( < L1 MP1 IS1 ! SGM*L ! L2 MP2 IS2 > ) OF SPIN-ORBIT COUPLING
    !
    !      FOR COMPLEX :: SPHERICAL HARMONICS FOR :
    !      L >= 0 ,-L <= M <= L , SGM = 1 OR -1 , IS = 1   OR -1
    !
    !                             SATOSHI TAKIZAWA, ISSP, MAR 1990
    !            MODIFIED BY      STEFAN BL"UGEL  , ISSP, MAR 1990
    ! *********************************************************************
    !
    IMPLICIT NONE
    !     ..
    !     .. Scalar Arguments ..
    INTEGER is1,is2,l1,l2,m1,m2
    !     ..
    !     .. Local Scalars ..
    REAL sgm1,sgm2
    !     ..
    !     ..
    IF (l1.NE.l2) THEN
       sgml = 0.0
       RETURN
    ELSE
       sgm1 = is1
       sgm2 = is2
       IF (l1.LT.0) THEN
          WRITE (oUnit,FMT=*) ' PROGRAM STOPS IN FUNCTION SGML ( L < 0 ) .'
          WRITE (oUnit,FMT=*) ' L1 =',l1,'    L2 =',l2
          CALL juDFT_error("SGMLR",calledby="sgml")
       ELSE IF ((ABS(m1).GT.l1) .OR. (ABS(m2).GT.l2)) THEN
          WRITE (oUnit,FMT=*) ' PROGRAM STOPS IN SGMLC ( jij%M < L OR L < jij%M )'
          WRITE (oUnit,FMT=*) ' L1 =',l1,'    L2 =',l2
          WRITE (oUnit,FMT=*) ' M1 =',m1,'    M2 =',m2
          CALL juDFT_error("SGML",calledby="sgml")
       ELSE IF ((is1.NE.-1.AND.is1.NE.1) .OR. (is2.NE.-1.AND.is2.NE.1)) THEN
          WRITE (oUnit,FMT=*) ' PROGRAM STOPS IN FUNCTION SGMLC ( S >< +-1/2 ) .'
          WRITE (oUnit,FMT=*) ' S1 =',0.5*sgm1,'    S2 =',0.5*sgm2
          CALL juDFT_error("SGML",calledby="sgml")
       END IF
       !
       !
       IF (m1.EQ.m2+1 .AND. is1.EQ.is2-2) THEN
          sgml = SQRT(REAL((l2-m2)* (l2+m2+1)))
       ELSE IF (m1.EQ.m2-1 .AND. is1.EQ.is2+2) THEN
          sgml = SQRT(REAL((l2+m2)* (l2-m2+1)))
       ELSE IF (m1.EQ.m2 .AND. is1.EQ.is2) THEN
          sgml = m2*sgm2
       ELSE
          sgml = 0.0
       END IF
       RETURN
    END IF
    !
    RETURN
  END FUNCTION sgml
END MODULE m_sgml


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> An example that shows how to compute the overlap matrix.
PROGRAM OverlapExample
  USE DataTypesModule, ONLY : NTREAL
  USE PermutationModule, ONLY : Permutation_t, ConstructRandomPermutation
  USE ProcessGridModule, ONLY : ConstructProcessGrid, global_grid, &
       & DestructProcessGrid
  USE PSMatrixModule, ONLY : Matrix_ps, ConstructEmptyMatrix, &
       & WriteMatrixToMatrixMarket, FillMatrixFromTripletList, DestructMatrix
  USE SolverParametersModule, ONLY : SolverParameters_t
  USE SquareRootSolversModule, ONLY : InverseSquareRoot
  USE TimerModule, ONLY : RegisterTimer, StartTimer, StopTimer, PrintAllTimers
  USE TripletListModule, ONLY : TripletList_r, ConstructTripletList, &
       & AppendToTripletList
  USE TripletModule, ONLY : Triplet_r
  USE MPI
  IMPLICIT NONE
  !! Parameters
  INTEGER :: process_rows, process_columns, process_slices
  REAL(NTREAL) :: threshold, convergence_threshold
  TYPE(SolverParameters_t) :: solver_parameters
  INTEGER :: basis_functions
  !! Matrices
  TYPE(Matrix_ps) :: Overlap, ISQOverlap
  TYPE(Permutation_t) :: permutation
  !! Triplet List
  TYPE(TripletList_r) :: triplet_list
  TYPE(Triplet_r) :: temporary_triplet
  !! For Parallelism
  INTEGER :: start_row, start_column
  INTEGER :: end_row, end_column
  INTEGER :: local_rows, local_columns
  !! MPI Variables
  INTEGER :: ierr
  INTEGER :: provided
  INTEGER :: rank
  !! Temporary Variables
  CHARACTER(len=80) :: argument
  CHARACTER(len=80) :: argument_value
  INTEGER :: column_counter, row_counter
  INTEGER :: counter
  REAL(ntreal) :: integral_value

  !! Setup MPI
  CALL MPI_Init_thread(MPI_THREAD_SERIALIZED, provided, ierr)
  CALL MPI_Comm_rank(MPI_COMM_WORLD,rank, ierr)

  !! Process the input parameters.
  DO counter=1,command_argument_count(),2
     CALL get_command_argument(counter,argument)
     CALL get_command_argument(counter+1,argument_value)
     SELECT CASE(argument)
     CASE('--basis_functions')
        READ(argument_value,*) basis_functions
     CASE('--convergence_threshold')
        READ(argument_value,*) convergence_threshold
     CASE('--process_rows')
        READ(argument_value,*) process_rows
     CASE('--process_columns')
        READ(argument_value,*) process_columns
     CASE('--process_slices')
        READ(argument_value,*) process_slices
     CASE('--threshold')
        READ(argument_value,*) threshold
     END SELECT
  END DO

  !! Setup the process grid.
  CALL ConstructProcessGrid(MPI_COMM_WORLD, process_rows, process_columns, &
       & process_slices)

  !! Timers
  CALL RegisterTimer("Construct Triplet List")
  CALL RegisterTimer("Fill")
  CALL RegisterTimer("Solve")

  !! Figure out which part of the local matrix we will store
  local_rows = basis_functions/process_rows
  local_columns = basis_functions/process_columns
  start_row = (local_rows)*global_grid%my_row + 1
  start_column = (local_columns)*global_grid%my_column + 1
  end_row = start_row + local_rows - 1
  end_column = start_column + local_columns - 1

  !! Build The Empty Matrices
  CALL ConstructEmptyMatrix(Overlap, basis_functions)
  CALL ConstructEmptyMatrix(ISQOverlap, basis_functions)

  !! Compute The Overlap Matrix
  CALL StartTimer("Construct Triplet List")
  CALL ConstructTripletList(triplet_list)
  DO row_counter=start_row,end_row
     DO column_counter=start_column,end_column
        integral_value = ComputeIntegral(row_counter,column_counter)
        IF (integral_value .GT. threshold) THEN
           temporary_triplet%point_value = integral_value
           temporary_triplet%index_column = column_counter
           temporary_triplet%index_row = row_counter
           CALL AppendToTripletList(triplet_list,temporary_triplet)
        END IF
     END DO
  END DO
  CALL StopTimer("Construct Triplet List")

  CALL StartTimer("Fill")
  CALL FillMatrixFromTripletList(Overlap, triplet_list)
  CALL StopTimer("Fill")

  !! Set Up The Solver Parameters.
  CALL ConstructRandomPermutation(permutation, &
       & Overlap%logical_matrix_dimension)
  solver_parameters = SolverParameters_t(&
       & converge_diff_in=convergence_threshold, threshold_in=threshold, &
       & BalancePermutation_in=permutation, be_verbose_in=.TRUE.)

  !! Call the solver routine.
  CALL StartTimer("Solve")
  CALL InverseSquareRoot(Overlap, ISQOverlap, solver_parameters)
  CALL StopTimer("Solve")

  !! Write the output to file
  CALL WriteMatrixToMatrixMarket(Overlap,"input.mtx")
  CALL WriteMatrixToMatrixMarket(ISQOverlap,"output.mtx")

  !! Cleanup
  CALL PrintAllTimers()
  CALL DestructMatrix(Overlap)
  CALL DestructMatrix(ISQOverlap)
  CALL DestructProcessGrid
  CALL MPI_Finalize(ierr)
CONTAINS!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  FUNCTION ComputeIntegral(row,column) RESULT(integral_value)
    !! Parameters
    INTEGER :: row
    INTEGER :: column
    REAL(ntreal) :: integral_value

    IF (row .EQ. column) THEN
       integral_value = 1.0
    ELSE
       integral_value = 1.0/(ABS(row - column)+1)
    END IF
  END FUNCTION ComputeIntegral
END PROGRAM OverlapExample