module ewald_sums
use types, only: dp
use constants, only: pi, i_
implicit none
private
public ewald, ewald2, direct_sum, fred2fcart, sred2scart, ewald_box, &
    ewald_fft1, ewald_fft2, min_distance

contains

subroutine ewald(eew,gmet,grewtn,natom,ntypat,rmet,typat,ucvol,xred,zion)
! This subroutine was taken from ABINIT
!
!{\src2tex{textfont=tt}}
!!****f* ABINIT/ewald
!!
!! NAME
!! ewald
!!
!! FUNCTION
!! Compute Ewald energy and derivatives with respect to dimensionless
!!  reduced atom coordinates xred.
!!
!! COPYRIGHT
!! Copyright (C) 1998-2012 ABINIT group (DCA, XG, GMR)
!! This file is distributed under the terms of the
!! GNU General Public License, see ~abinit/COPYING
!! or http://www.gnu.org/copyleft/gpl.txt .
!! For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
!!
!! INPUTS
!! gmet(3,3)=metric tensor in reciprocal space (bohr^-2)
!! natom=number of atoms in unit cell
!! ntypat=numbe of type of atoms
!! rmet(3,3)=metric tensor in real space (bohr^2)
!! typat(natom)=integer label of each type of atom (1,2,...)
!! ucvol=unit cell volume (bohr^3)
!! xred(3,natom)=relative coords of atoms in unit cell (dimensionless)
!! zion(ntypat)=charge on each type of atom (real number)
!!
!! OUTPUT
!! eew=final ewald energy in hartrees
!! grewtn(3,natom)=grads of eew wrt xred(3,natom), hartrees.
!Arguments ------------------------------------
!scalars
integer, intent(in) :: natom, ntypat
real(dp), intent(in) :: ucvol
real(dp), intent(out) :: eew
!arrays
integer, intent(in) :: typat(natom)
real(dp), intent(in) :: gmet(3,3), rmet(3,3), xred(3,natom), zion(ntypat)
real(dp), intent(out) :: grewtn(3, natom)

!Local variables-------------------------------
integer :: ia,ib,ig1,ig2,ig3,ir1,ir2,ir3,newg,newr,ng,nr
real(dp) :: arg,c1i,ch,chsq,drdta(3),eta,fac
real(dp) :: fraca(3),fracb(3),gsq,gsum,phi,phr,r(3)
real(dp) :: reta,rmagn,rsq,sumg,summi,summr,sumr
real(dp) :: term

!Add up total charge and sum of $charge^2$ in cell
ch   = sum(zion(typat))
chsq = sum(zion(typat)**2)

!Compute eta, the Ewald summation convergence parameter,
!for approximately optimized summations:
!A bias is introduced, because G-space summation scales
!better than r space summation ! Note : debugging is the most
!easier at fixed eta.
eta = pi*200._dp/33._dp*sqrt(1.69_dp*sum(gmet)/sum(rmet))

!Conduct reciprocal space summations
fac = pi**2/eta
gsum = 0
grewtn = 0
!Sum over G space, done shell after shell until all
!contributions are too small.
ng = 0
do
    ng = ng + 1
    newg = 0
    do ig3 = -ng, ng
    do ig2 = -ng, ng
    do ig1 = -ng, ng
        ! Exclude shells previously summed over
        if (abs(ig1)==ng .or. abs(ig2)==ng .or. abs(ig3)==ng .or. ng==1) then
            ! gsq is G dot G = |G|^2
            gsq = gmet(1,1)*ig1**2+gmet(2,2)*ig2**2+gmet(3,3)*ig3**2 + &
                2*(gmet(2,1)*ig1*ig2+gmet(3,1)*ig1*ig3+gmet(3,2)*ig3*ig2)
            ! Skip g=0:
            if (gsq > 1e-20_dp) then
                arg = fac*gsq
                ! Larger arg gives 0 contribution because of exp(-arg)
                if (arg <= 80) then
                    ! When any term contributes then include next shell
                    newg = 1
                    term = exp(-arg)/gsq
                    summr = 0
                    summi = 0
                    ! Note that if reduced atomic coordinates xred drift
                    ! outside of unit cell (outside [0,1)) it is irrelevant in
                    ! the following term, which only computes a phase.
                    do ia = 1, natom
                        arg = 2*pi*dot_product([ig1, ig2, ig3], xred(:, ia))
                        ! Sum real and imaginary parts (avoid complex variables)
                        summr = summr+zion(typat(ia))*cos(arg)
                        summi = summi+zion(typat(ia))*sin(arg)
                    end do
                    ! The following two checks avoid an annoying
                    ! underflow error message
                    if (abs(summr) < 1e-16_dp) summr = 0
                    if (abs(summi) < 1e-16_dp) summi = 0
                    ! The product of term and summr**2 or summi**2 below
                    ! can underflow if not for checks above
                    gsum = gsum + term*(summr**2+summi**2)
                    do ia = 1, natom
                        ! Again only phase is computed so xred may fall outside
                        ! [0,1).
                        arg = 2*pi*dot_product([ig1, ig2, ig3], xred(:, ia))
                        phr =  cos(arg)
                        phi = -sin(arg)
                        ! (note: do not need real part, commented out)
                        ! c1r=(phr*summr-phi*summi)*(term*zion(typat(ia)))
                        c1i = (phi*summr+phr*summi)*(term*zion(typat(ia)))
                        ! compute coordinate gradients
                        grewtn(:, ia) = grewtn(:, ia) - c1i*[ig1, ig2, ig3]
                    end do
                end if
            end if
        end if
    end do
    end do
    end do
    ! Check if new shell must be calculated
    if (newg == 0) exit
end do
sumg = gsum/(2*pi*ucvol)
!Stress tensor is now computed elsewhere (ewald2) hence do not need
!length scale gradients (used to compute them here).

!normalize coordinate gradients by unit cell volume ucvol
grewtn = -2*grewtn(:,:)/ucvol

!Conduct real space summations
reta = sqrt(eta)
fac = 2*sqrt(eta/pi)
sumr = 0
!In the following a summation is being conducted over all
!unit cells (ir1, ir2, ir3) so it is appropriate to map all
!reduced coordinates xred back into [0,1).
!
!Loop on shells in r-space as was done in g-space
nr = 0
do
    nr = nr + 1
    newr = 0
    ! Triple loop over real space points and associated condition of new shell
    do ir3 = -nr, nr
    do ir2 = -nr, nr
    do ir1 = -nr, nr
      if (abs(ir3)==nr .or. abs(ir2)==nr .or. abs(ir1)==nr .or. nr==1) then
        do ia = 1, natom
          ! Map reduced coordinate xred(mu,ia) into [0,1)
          fraca = xred(:,ia)-aint(xred(:,ia))+0.5_dp-sign(0.5_dp,xred(:,ia))
          drdta = 0
          do ib = 1, natom
              fracb = xred(:,ib)-aint(xred(:,ib))+0.5_dp-sign(0.5_dp,xred(:,ib))
              r = [ir1, ir2, ir3] + fracb - fraca
              rsq = rmet(1,1)*r(1)**2+rmet(2,2)*r(2)**2+rmet(3,3)*r(3)**2 + &
                2*(rmet(2,1)*r(2)*r(1)+rmet(3,2)*r(3)*r(2)+rmet(3,1)*r(1)*r(3))
              ! Avoid zero denominators in 'term':
              if (rsq >= 1e-24_dp) then
                  ! Note: erfc(8) is about 1.1e-29,
                  ! so do not bother with larger arg.
                  ! Also: exp(-64) is about 1.6e-28,
                  ! so do not bother with larger arg**2 in exp.
                  term=0
                  if (eta*rsq < 64) then
                      newr = 1
                      rmagn = sqrt(rsq)
                      term = erfc(reta*rmagn) / rmagn
                      sumr = sumr+zion(typat(ia))*zion(typat(ib))*term
                      term = zion(typat(ia)) * zion(typat(ib)) * &
                          (term+fac*exp(-eta*rsq))/rsq
                      ! Compute terms related to coordinate gradients
                      drdta = drdta + term*matmul(rmet, r)
                  end if
              end if
          end do ! ib
          grewtn(:, ia) = grewtn(:, ia) + drdta
        end do ! ia
      end if
    end do
    end do
    end do
    ! Check if new shell must be calculated
    if (newr == 0) exit
end do
! Finally assemble Ewald energy, eew
eew = sumg+sumr/2-chsq*reta/sqrt(pi)-pi*ch**2/(2*eta*ucvol)
end subroutine ewald

subroutine ewald2(gmet,natom,ntypat,rmet,rprimd,gprimd,stress,typat,ucvol, &
        xred,zion)
! This subroutine was taken from ABINIT
!
!{\src2tex{textfont=tt}}
!!****f* ABINIT/ewald2
!!
!! NAME
!! ewald2
!!
!! FUNCTION
!! Compute the part of the stress tensor coming from the Ewald energy
!! which is calculated by derivating the Ewald energy with respect to
!! strain.
!! See Nielsen and Martin, Phys. Rev. B 32, 3792 (1985).
!! Definition of stress tensor is $(1/ucvol)*d(Etot)/d(strain(a,b))$.
!!
!! COPYRIGHT
!! Copyright (C) 1998-2014 ABINIT group (JCC, DCA, XG, GMR)
!! This file is distributed under the terms of the
!! GNU General Public License, see ~abinit/COPYING
!! or http://www.gnu.org/copyleft/gpl.txt .
!! For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
!!
!! INPUTS
!! gmet(3,3)=metric tensor in reciprocal space (bohr^-2)
!! natom=number of atoms in umit cell
!! ntypat=number of type of atoms
!! rmet(3,3)=metric tensor in real space (bohr^2) (inverse transpose of gmet)
!! rprimd(3,3)=dimensional primitive translations in real space (bohr)
!! gprimd(3,3)=dimensional primitive translations in reciprocal space (1/bohr)
!! typat(natom)=integer label of each type of atom (1,2,...)
!! ucvol=unit cell volume (bohr^3)
!! xred(3,natom)=relative coords of atoms in unit cell (dimensionless)
!! zion(ntypat)=charge on each type of atom (real number)
!!
!! OUTPUT
!! $stress(6)=(1/ucvol)*gradient$ of Ewald energy with respect to strain,
!!      in hartrees/bohr^3
!! Cartesian components of stress are provided for this symmetric
!! tensor in the order 11 22 33 32 31 21.
!!
!Arguments ------------------------------------
!scalars
integer, intent(in) :: natom, ntypat
real(dp), intent(in) :: ucvol
!arrays
integer, intent(in) :: typat(natom)
real(dp), intent(in) :: gmet(3,3), rmet(3,3), rprimd(3,3), gprimd(3,3), &
    xred(3,natom), zion(ntypat)
real(dp), intent(out) :: stress(6)

!Local variables-------------------------------
integer :: ia,ib,ig1,ig2,ig3,ir1,ir2,ir3,newg,newr,ng,nr
real(dp) :: arg1,arg2,arg3,ch,dderfc,eta,fac,fraca(3)
real(dp) :: fracb(3),g(3),gsq,r(3),rc(3)
real(dp) :: reta,rmagn,rsq,summi,summr,t(6),term1
real(dp) :: term4
real(dp) :: strg(6),strr(6)

!Add up total charge and sum of charge^2 in cell
ch = sum(zion(typat))

!Compute eta, the Ewald summation convergence parameter,
!for approximately optimized summations:
!Here, a bias is introduced, because G-space summation scales
!better than r space summation !
eta = pi*200.0_dp/33.0_dp*sqrt(1.69_dp*sum(gmet)/sum(rmet))

fac = pi**2/eta

!Conduct reciprocal space summations
strg = 0
!Sum over G space, done shell after shell until all
!contributions are too small
ng=0
do
    ng = ng+1
    newg = 0
    do ig3 = -ng, ng
    do ig2 = -ng, ng
    do ig1 = -ng, ng
        ! Exclude shells previously summed over
        if (abs(ig1)==ng .or. abs(ig2)==ng .or. abs(ig3)==ng .or. ng==1) then
            g = matmul(gprimd, [ig1, ig2, ig3]) ! Cartesian components of each G
            gsq = sum(g**2) ! |G|^2 (no pi factors)
            ! skip g=0:
            if (gsq > 1e-20_dp) then
                arg1 = fac*gsq
                ! larger arg1 gives 0 contribution because of exp(-arg1)
                if (arg1 <= 80) then
                    ! When any term contributes then include next shell
                    newg = 1
                    term1 = exp(-arg1)/arg1
                    summr = 0
                    summi = 0
                    do ia = 1, natom
                        arg2 = 2*pi*dot_product([ig1, ig2, ig3], xred(:, ia))
                        ! Sum real and imaginary parts (avoid complex variables)
                        summr = summr+zion(typat(ia))*cos(arg2)
                        summi = summi+zion(typat(ia))*sin(arg2)
                    end do
                    ! Avoid underflow error messages
                    if (abs(summr) < 1e-16_dp) summr = 0
                    if (abs(summi) < 1e-16_dp) summi = 0
                    t = (2/gsq)*(1+arg1) * [g(1)**2, g(2)**2, g(3)**2, &
                        g(2)*g(3), g(1)*g(3), g(1)*g(2)] - [1, 1, 1, 0, 0, 0]
                    strg = strg + t*term1*(summr*summr+summi*summi)
                end if
           end if
        end if
    end do
    end do
    end do
    ! Check if new shell must be calculated
    if (newg == 0) exit
end do

!Conduct real space summations
reta = sqrt(eta)
strr = 0
!Loop on shells in r-space as was done in g-space
nr = 0
do
    nr = nr + 1
    newr = 0
    ! Triple loop over real space points, and associated new shell condition
    do ir3 = -nr, nr
    do ir2 = -nr, nr
    do ir1 = -nr, nr
      if (abs(ir3)==nr .or. abs(ir2)==nr .or. abs(ir1)==nr .or. nr==1) then
        do ia=1,natom
          ! Convert reduced atomic coordinates to [0,1)
          fraca = xred(:,ia)-aint(xred(:,ia))+0.5_dp-sign(0.5_dp,xred(:,ia))
          do ib = 1, natom
              fracb=xred(:,ib)-aint(xred(:,ib))+0.5_dp-sign(0.5_dp,xred(:,ib))
              r = [ir1, ir2, ir3] + fracb - fraca
              ! Convert from reduced to cartesian coordinates
              rc = matmul(rprimd, r)
              ! Compute |r|^2
              rsq = sum(rc**2)
              rmagn = sqrt(rsq)
              ! Avoid zero denominators in 'term':
              if (rmagn >= 1e-12_dp) then
                  ! Note: erfc(8) is about 1.1e-29,
                  ! so do not bother with larger arg.
                  ! Also: exp(-64) is about 1.6e-28,
                  ! so do not bother with larger arg**2 in exp.
                  arg3=reta*rmagn
                  if (arg3 < 8) then
                      newr = 1
                      ! derivative of the erfc:
                      dderfc = (-2/sqrt(pi))*exp(-eta*rsq)
                      term4 = zion(typat(ia)) * zion(typat(ib)) * &
                          (dderfc-erfc(arg3)/arg3)
                      strr = strr + term4 * [rc(1)**2, rc(2)**2, rc(3)**2, &
                          rc(2)*rc(3), rc(1)*rc(3), rc(1)*rc(2)] / rsq
                  end if
              end if
          end do ! ib
        end do ! ia
      end if
    end do ! ir1
    end do ! ir2
    end do ! ir3
    ! Check if new shell must be calculated
    if (newr == 0) exit
end do
! Finally assemble stress tensor coming from Ewald energy, stress
! (note division by unit cell volume in accordance with definition
! found in Nielsen and Martin, Phys. Rev. B 32, 3792 (1985).)
strg(:3) = strg(:3) + ch**2
stress = (reta*strr/2 + pi*strg/(2*ucvol*eta)) / ucvol
end subroutine ewald2

subroutine fred2fcart(fcart, fred, gprim)
! Convert forces from rprim reduced coordinates to cartesian coordinates
real(dp), intent(in) :: gprim(3, 3) ! gprim(:, i) = G_i (reciprocal vectors)
! fred(:, i) = F_i (force on i-th atom in gprim coordinates)
real(dp), intent(in) :: fred(:, :)
! fcart(:, i) = F_i (force on i-th atom in cartesian coordinates)
real(dp), intent(out) :: fcart(:, :)
integer :: i, n
n = size(fred, 2)
do i = 1, n
    fcart(:, i) = gprim(:, 1)*fred(1, i) + gprim(:, 2)*fred(2, i) &
        + gprim(:, 3)*fred(3, i)
end do
end subroutine

subroutine sred2scart(scart, sred, gprim)
! Convert stress tensor from rprim reduced coordinates to cartesian coordinates
! Symmetric storage mode for a 3x3 tensor is a 6 element array with elements
! 11, 22, 33, 32, 31 and 21.
real(dp), intent(in) :: gprim(3, 3) ! gprim(:, i) = G_i (reciprocal vectors)
! sred(6) stress tensor in reduced coordinates
real(dp), intent(in) :: sred(:)
! scart(6) stress tensor in cartesian coordinates
real(dp), intent(out) :: scart(:)
real(dp) :: w(3, 3)
w(1, 1) = sred(1)
w(2, 2) = sred(2)
w(3, 3) = sred(3)
w(3, 2) = sred(4); w(2, 3) = sred(4)
w(3, 1) = sred(5); w(1, 3) = sred(5)
w(2, 1) = sred(6); w(1, 2) = sred(6)
w = matmul(matmul(gprim, w), transpose(gprim))
scart(1) = w(1, 1)
scart(2) = w(2, 2)
scart(3) = w(3, 3)
scart(4) = w(2, 3)
scart(5) = w(1, 3)
scart(6) = w(1, 2)
end subroutine

subroutine direct_sum(q, r, L, ncut, E, forces)
! Calculates the Coulombic energy E and forces as a direc lattice sum.
!
! We use a spherically ordered direct lattice sum. If the unit cell dipole
! moment is non-zero, the sum needs to be corrected in order to obtain the
! correct Ewald energy and forces, see [1] for more details.
!
! The summation is converging very slowly, but the subroutine is simple to
! implement and maintain, so it is used for testing the correctness of faster
! more advanced methods. The convergence is achieved by increasing 'ncut'.
!
! [1] Roberts, J. E., Schnitker, J. (1994). How the unit cell surface charge
! distribution affects the energetics of ion–solvent interactions in
! simulations. The Journal of Chemical Physics, 101(6), 5024.
! doi:10.1063/1.467425
real(dp), intent(in) :: q(:) ! q(i) is charge of i-th particle
real(dp), intent(in) :: r(:, :) ! r(:, i) is (x, y, z) coordinates of i-th par.
real(dp), intent(in) :: L ! length of the unit cell (box)
integer, intent(in) :: ncut ! cutoff
real(dp), intent(out) :: E ! Calculated energy
real(dp), intent(out) :: forces(:, :) ! forces(:, i) is a force on i-th particle
integer :: N, i, j, nx, ny, nz
real(dp) :: d_ji(3), d
N = size(q)
E = 0
forces = 0

! Calculate the spherically ordered direct lattice sum
do i = 1, N
    do j = 1, N
        do nx = -ncut, ncut
        do ny = -ncut, ncut
        do nz = -ncut, ncut
            if (nx == 0 .and. ny == 0 .and. nz == 0 .and. i == j) cycle
            if (sqrt(real(nx**2+ny**2+nz**2, dp)) > ncut) cycle
            ! Vector pointing from particle j -> i: d_ji = r_i - r_j
            d_ji = r(:, i)-r(:, j) + [nx, ny, nz]*L
            d = sqrt(sum(d_ji**2)) ! |r_i - r_j|
            E = E + q(i)*q(j) / d
            forces(:, i) = forces(:, i) + q(i)*q(j)*d_ji/d**3
        end do
        end do
        end do
    end do
end do
E = E / 2

! Calculate the dipole moment of the unit cell
d_ji = 0
do i = 1, N
    d_ji = d_ji + q(i)*r(:, i)
end do

! Correct the sum in order to obtain Ewald energy and forces
! Eq. (9) in [1]
E = E - 2*pi/3*sum(d_ji**2)/L**3
! Eq. (13) in [1]
do i = 1, N
    forces(:, i) = forces(:, i) + 4*pi/(3*L**3)*q(i)*d_ji
end do
end subroutine

subroutine ewald_box(L, x, q, E, forces, stress)
! Special case of Ewald summation for a box L^3. This calls ewald() and
! ewald2() internally. Because of the simplified geometry, it has simpler
! arguments and it calculates the various geometric quantities automatically
! before calling ewald(). All quantities are in a.u.
real(dp), intent(in) :: L ! Length of the box
real(dp), intent(in) :: x(:, :) ! x(:, i) position of i-th ion in [0, L]^3
real(dp), intent(in) :: q(:) ! r(i) charge of i-th ion
real(dp), intent(out) :: E ! ion-ion electrostatic potential energy
real(dp), intent(out) :: forces(:, :) ! forces(:, i) forces on i-th ion
real(dp), intent(out) :: stress(:) ! stress(6) the stress tensor

real(dp) :: rmet(3, 3), gmet(3, 3), rprim(3, 3), gprim(3, 3), ucvol
real(dp), dimension(3, size(x, 2)) :: xred, grewtn
integer :: typat(size(x, 2))
real(dp) :: zion(size(x, 2))
integer :: natom, ntypat, i
natom = size(x, 2)
ntypat = natom
do i = 1, ntypat
    typat(i) = i
end do
zion = q

! Setup geometric quantities:
rmet = 0
rmet(1, 1) = L**2
rmet(2, 2) = L**2
rmet(3, 3) = L**2

! gmet = inv(rmet)
gmet = 0
gmet(1, 1) = 1/L**2
gmet(2, 2) = 1/L**2
gmet(3, 3) = 1/L**2

! ucvol = sqrt(det(rmet))
ucvol = L**3

! Reciprocal primitive vectors (without 2*pi) in cartesian coordinates.
! gmet = matmul(transpose(gprim), gprim) = inv(rprim)
gprim = 0
gprim(1, 1) = 1 / L
gprim(2, 2) = 1 / L
gprim(3, 3) = 1 / L

! Real space primitive vectors
! rmet = matmul(transpose(rprim), rprim)
rprim = 0
rprim(1, 1) = L
rprim(2, 2) = L
rprim(3, 3) = L

xred = x / L

call ewald(E,gmet,grewtn,natom,ntypat,rmet,typat,ucvol,xred,zion)
call ewald2(gmet,natom,ntypat,rmet,rprim,gprim,stress,typat,ucvol,xred,zion)
call fred2fcart(forces, grewtn, gprim)
! Make forces out of gradients:
forces = -forces
stress = -stress * ucvol
end subroutine

subroutine ewald_fft1(L, x, q, Ng, rc, E)
use ofdft_fft, only: reciprocal_space_vectors, real2fourier, &
    real_space_vectors, fourier2real
real(dp), intent(in) :: L ! Length of the box
real(dp), intent(in) :: x(:, :) ! x(:, i) position of i-th ion in [0, L]^3
real(dp), intent(in) :: q(:) ! r(i) charge of i-th ion
integer, intent(in) :: Ng
real(dp), intent(in) :: rc
real(dp), intent(out) :: E ! ion-ion electrostatic potential energy
integer :: N, ii, i, j, k, i_, j_, k_, Ng_rc, Ng0(3)
real(dp) :: Ig, v0, Isph, rho_minus, r, Xj(3), d(3)
real(dp), allocatable :: rho_tilde_minus(:, :, :)
complex(dp), allocatable :: rho_tilde_minusG(:, :, :)
real(dp), allocatable :: G(:, :, :, :), G2(:, :, :), Xn(:,:,:,:)
! The accuracy to which the value of the Gaussian vanishes at r=rc
!real(dp), parameter :: eps = 1e-16_dp ! eps = exp(-alpha*(r/rc)**2) for r=rc
!real(dp), parameter :: alpha = -log(eps)
real(dp), parameter :: alpha = 37

real(dp), parameter :: gauss_const = 1/(pi**(3._dp/2) * erf(sqrt(alpha)) / alpha**(3._dp/2) - 2*pi*exp(-alpha)/alpha)

print *, "alpha=", alpha
print *, "gauss_const=", gauss_const
print *, "rc = ", rc

rho_minus = -sum(q)/L**3

!Ig = 10976 / (17875*rc)
!Isph = 14*pi*rc**2/75
!v0 = 12/(5*rc)

!Ig = (517399110137._dp/809268832200._dp)/rc
!Isph = 91*pi*rc**2/690
!v0 = 11/(4*rc)

Ig = 2.0103202076225765715378_dp / rc
Isph = 0.0849079095564808927765_dp * rc**2
v0 = 6.8636625175776977414444_dp / rc

N = size(q)
E = 0

do i = 1, N
    E = E + 1/2._dp * q(i)**2 * (Ig-v0) + q(i) * Isph * rho_minus
end do

allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng), Xn(Ng, Ng, Ng, 3))
allocate(rho_tilde_minus(Ng,Ng,Ng), rho_tilde_minusG(Ng,Ng,Ng))

call real_space_vectors([L, L, L], Xn)
call reciprocal_space_vectors([L, L, L], G, G2)

rho_tilde_minus = 0
Ng_rc = int(Ng*rc/L) + 2
do ii = 1, N
    Ng0 = int(Ng*x(:, ii)/L)
    do k_ = Ng0(3)-Ng_rc, Ng0(3)+Ng_rc
    do j_ = Ng0(2)-Ng_rc, Ng0(2)+Ng_rc
    do i_ = Ng0(1)-Ng_rc, Ng0(1)+Ng_rc
        i = i_ - int(Ng*floor(real(i_-1, dp)/Ng))
        j = j_ - int(Ng*floor(real(j_-1, dp)/Ng))
        k = k_ - int(Ng*floor(real(k_-1, dp)/Ng))
        Xj = x(:, ii)-Xn(i,j,k,:)+[L/2, L/2, L/2]
        Xj = Xj - L*floor(Xj/L)
        d = [L/2, L/2, L/2] - Xj
        r = sqrt(sum(d**2))
        rho_tilde_minus(i,j,k) = rho_tilde_minus(i,j,k) + &
            q(ii)*g4_fn(r, rc, alpha, gauss_const)
    end do
    end do
    end do
end do

call real2fourier(rho_tilde_minus, rho_tilde_minusG)

do k = 1, Ng
do j = 1, Ng
do i = 1, Ng
    if (i == 1 .and. j == 1 .and. k == 1) cycle
    E = E + 2*pi*abs(rho_tilde_minusG(i,j,k))**2/G2(i,j,k)*L**3
end do
end do
end do

contains

    real(dp) function g_fn(r, rc) result(g)
    real(dp), intent(in) :: r, rc
    if (r > rc) then
        g = 0
    else
        g = -21*(r-rc)**3*(6*r**2+3*r*rc+rc**2)/(5*pi*rc**8)
    end if
    end function

    real(dp) function g2_fn(r, rc) result(g)
    real(dp), intent(in) :: r, rc
    real(dp), parameter :: C = 0.4410888872766044004562838172_dp
    if (r >= rc) then
        g = 0
    else
        ! Bump function
        g = exp(-1/(1-(r/rc)**2)) / (C*rc**3)
    end if
    end function

    real(dp) function g3_fn(r, rc) result(g)
    real(dp), intent(in) :: r, rc
    if (r >= rc) then
        g = 0
    else
        g = 21*(r - rc)**10*(48620*r**9 + 24310*r**8*rc + 11440*r**7*rc**2 + &
        5005*r**6*rc**3 + 2002*r**5*rc**4 + 715*r**4*rc**5 + 220*r**3*rc**6 + &
        55*r**2*rc**7 + 10*r*rc**8 + rc**9)/(4*pi*rc**22)
    end if
    end function

    real(dp) function g4_fn(r, rc, alpha, C) result(g)
    real(dp), intent(in) :: r, rc, alpha, C
    if (r >= rc) then
        g = 0
    else
        g = C*exp(-alpha*(r/rc)**2) / rc**3
    end if
    end function

end subroutine

subroutine ewald_fft2(L, x, q, Ng, rc, E)
use ofdft_fft, only: reciprocal_space_vectors, real2fourier, &
    real_space_vectors, fourier2real, radial_density_fourier
real(dp), intent(in) :: L ! Length of the box
real(dp), intent(in) :: x(:, :) ! x(:, i) position of i-th ion in [0, L]^3
real(dp), intent(in) :: q(:) ! r(i) charge of i-th ion
integer, intent(in) :: Ng
real(dp), intent(in) :: rc
real(dp), intent(out) :: E ! ion-ion electrostatic potential energy
integer, parameter :: N_rad_grid = 10000
real(dp) :: R(N_rad_grid), rho0(N_rad_grid)
integer :: N, i, j, k, ii
real(dp) :: Ig, v0, Isph, rho_minus
real(dp), allocatable :: rho0G(:,:,:)
complex(dp) :: rhoG
real(dp), allocatable :: G(:, :, :, :), G2(:, :, :)

rho_minus = -sum(q)/L**3

!Ig = 10976 / (17875*rc)
!Isph = 14*pi*rc**2/75
!v0 = 12/(5*rc)

Ig = (517399110137._dp/809268832200._dp)/rc
Isph = 91*pi*rc**2/690
v0 = 11/(4*rc)

N = size(q)

allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng))
allocate(rho0G(Ng,Ng,Ng))

call reciprocal_space_vectors([L,L,L], G, G2)

do i = 1, N_rad_grid
    R(i) = rc * i / N_rad_grid
    rho0(i) = g3_fn(R(i), rc)
end do
call radial_density_fourier(R, rho0, L, rho0G)

E = 0
do i = 1, N
    E = E + 1/2._dp * q(i)**2 * (Ig-v0) + q(i) * Isph * rho_minus
end do

do k = 1, Ng
do j = 1, Ng
do i = 1, Ng
    if (i == 1 .and. j == 1 .and. k == 1) cycle
    rhoG = 0
    do ii = 1, N
        rhoG = rhoG - q(ii)*rho0G(i,j,k) * exp(i_ * &
            (G(i,j,k,1)*x(1,ii) + G(i,j,k,2)*x(2,ii) + G(i,j,k,3)*x(3,ii)))
    end do
    E = E + 2*pi*abs(rhoG)**2/G2(i,j,k)*L**3
end do
end do
end do

contains

    real(dp) function g_fn(r, rc) result(g)
    real(dp), intent(in) :: r, rc
    if (r > rc) then
        g = 0
    else
        g = -21*(r-rc)**3*(6*r**2+3*r*rc+rc**2)/(5*pi*rc**8)
    end if
    end function

    real(dp) function g2_fn(r, rc) result(g)
    real(dp), intent(in) :: r, rc
    real(dp), parameter :: C = 0.4410888872766044004562838172_dp
    if (r >= rc) then
        g = 0
    else
        ! Bump function
        g = exp(-1/(1-(r/rc)**2)) / (C*rc**3)
    end if
    end function

    real(dp) function g3_fn(r, rc) result(g)
    real(dp), intent(in) :: r, rc
    if (r >= rc) then
        g = 0
    else
        g = 21*(r - rc)**10*(48620*r**9 + 24310*r**8*rc + 11440*r**7*rc**2 + &
        5005*r**6*rc**3 + 2002*r**5*rc**4 + 715*r**4*rc**5 + 220*r**3*rc**6 + &
        55*r**2*rc**7 + 10*r*rc**8 + rc**9)/(4*pi*rc**22)
    end if
    end function

end subroutine

real(dp) function min_distance(X, L) result(rmin)
! Finds the minimum distance between two atoms (takes into account periodic BC).
real(dp), intent(in) :: X(:, :) ! X(:, i) is (x, y, z) coordinates of i-th par.
real(dp), intent(in) :: L ! length of the unit cell (box)
real(dp) :: r, d(3), Xj(3)
integer :: N, i, j
N = size(X, 2)
rmin = huge(1.0_dp)
do i = 1, N
    do j = 1, i-1
        Xj = X(:, j)-X(:, i)+[L/2, L/2, L/2]
        Xj = Xj - L*floor(Xj/L)
        d = [L/2, L/2, L/2] - Xj
        r = sqrt(sum(d**2))
        if (r < rmin) rmin = r
    end do
end do
end function

end module


C  (C) Copr. 1986-92 Numerical Recipes Software .#>.

C ******************************************************************
      SUBROUTINE lubksb(a,n,np,indx,b)
      INTEGER n,np,indx(n)
      REAL a(np,np),b(n)
      INTEGER i,ii,j,ll
      REAL sum
      ii=0
      do 12 i=1,n
        ll=indx(i)
        sum=b(ll)
        b(ll)=b(i)
        if (ii.ne.0)then
          do 11 j=ii,i-1
            sum=sum-a(i,j)*b(j)
11        continue
        else if (sum.ne.0.) then
          ii=i
        endif
        b(i)=sum
12    continue
      do 14 i=n,1,-1
        sum=b(i)
        do 13 j=i+1,n
          sum=sum-a(i,j)*b(j)
13      continue
        b(i)=sum/a(i,i)
14    continue
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software .#>.
C ******************************************************************
      SUBROUTINE ludcmp(a,n,np,indx,d)
      INTEGER n,np,indx(n),NMAX
      REAL d,a(np,np),TINY
      PARAMETER (NMAX=500,TINY=1.0e-40)
      INTEGER i,imax,j,k
      REAL aamax,dum,sum,vv(NMAX)
      d=1.
      do 12 i=1,n
        aamax=0.
        do 11 j=1,n
          if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))
11      continue
        IF (aamax.eq.0.) THEN
        CALL CONSOLEMSG('ludcmp: singular matrix in ludcmp')
        END IF
        vv(i)=1./aamax
12    continue
      do 19 j=1,n
        do 14 i=1,j-1
          sum=a(i,j)
          do 13 k=1,i-1
            sum=sum-a(i,k)*a(k,j)
13        continue
          a(i,j)=sum
14      continue
        aamax=0.
        do 16 i=j,n
          sum=a(i,j)
          do 15 k=1,j-1
            sum=sum-a(i,k)*a(k,j)
15        continue
          a(i,j)=sum
          dum=vv(i)*abs(sum)
          if (dum.ge.aamax) then
            imax=i
            aamax=dum
          endif
16      continue
        if (j.ne.imax)then
          do 17 k=1,n
            dum=a(imax,k)
            a(imax,k)=a(j,k)
            a(j,k)=dum
17        continue
          d=-d
          vv(imax)=vv(j)
        endif
        indx(j)=imax
        if(a(j,j).eq.0.)a(j,j)=TINY
        if(j.ne.n)then
          dum=1./a(j,j)
          do 18 i=j+1,n
            a(i,j)=a(i,j)*dum
18        continue
        endif
19    continue
      return
      END

C ******************************************************************
      SUBROUTINE MATINVN (N,NP,A,Y,D)
      INTEGER n,np,indx(n)                                                C UNUSED ,NMAX
      REAL a(np,np),y(np,np),d
C                                                                         C UNUSED DIMENSION IL(61)
 9040 FORMAT (' PROFILE COVARIANCE MATRIX USED IN THIS RUN'/
     1 (I9,61E10.3))

      do 12 i=1,N
      do 11 j=1,N
      Y(i,j)=0
11       CONTINUE
                Y(I,I)=1.
12       CONTINUE
       CALL LUDCMP(A,N,NP,INDX,D)
         do 14 j=1,N
       CALL LUBKSB(A,N,NP,INDX,Y(1,J))

14       CONTINUE

      RETURN
           END


Subroutine Euler(Rot_new,a,b,c)
  IMPLICIT NONE
  REAL*8, intent(in) :: Rot_new(3,3)
  REAL*8, intent(out):: a,b,c
  ! external
  REAL*8 :: ang
  ! locals
  REAL*8 :: Rot_old(3,3), z(3), zz(3)
  REAL*8 :: y(3),yy(3),yyy(3),pom(3)
  REAL*8 :: pi, y_norm
  INTEGER :: i, j
  !
  pi=acos(-1d0)
  do i=1,3
     do j=1,3
        Rot_old(i,j)=0
        if (i.eq.j) Rot_old(i,i)=1
     end do
  end do

  do j=1,3
     y(j)=Rot_old(j,2)
     yyy(j)=Rot_new(j,2)
     z(j)=Rot_old(j,3)
     zz(j)=Rot_new(j,3)
  end do

  call vecprod(z,zz,yy)
  y_norm=dsqrt(dot_product(yy,yy))

  if (y_norm.lt.1d-10) then
     a=ang(y,yyy)
     if (dot_product(z,zz).gt.0.d0) then
        c=0.d0
        b=0.d0
        if (yyy(1).gt.0.d0) a=2*pi-a
     else
        c=a
        a=0.d0
        b=pi
        if (yyy(1).lt.0.d0) c=2*pi-c
     end if
  else
     do j=1,3
        yy(j)=yy(j)/y_norm
     end do
     a=ang(y,yy)
     b=ang(z,zz)
     c=ang(yy,yyy)
     if (yy(1).gt.0.d0) a=2*pi-a
     call vecprod(yy,yyy,pom)
     if (dot_product(pom,zz).lt.0.d0) c=2*pi-c
  end if
END Subroutine Euler

Subroutine vecprod(a,b,c)
  IMPLICIT NONE
  REAL*8, intent(out) :: c(3)
  REAL*8, intent(in)  :: a(3), b(3)
  c(1)=a(2)*b(3)-a(3)*b(2)
  c(2)=a(3)*b(1)-a(1)*b(3)
  c(3)=a(1)*b(2)-a(2)*b(1)
end Subroutine vecprod

REAL*8 function ang(a,b)
  IMPLICIT NONE
  REAL*8, intent(in) :: a(3), b(3)
  ! locals
  REAL*8 :: c(3), pi, aa, bb, e, cc
  pi=dacos(-1.d0)
  aa=dsqrt(dot_product(a,a))
  bb=dsqrt(dot_product(b,b))
  e=dot_product(a,b)/(aa*bb)
  if (abs(e).gt.0.8) then
     call vecprod(a,b,c)
     cc=dsqrt(dot_product(c,c))
     ang=dasin(cc/(aa*bb))
     if (e.lt.0.d0) ang=pi-ang
  else
     ang=dacos(e)
  end if
end function ang


! Copyright 2012-2018, University of Strathclyde
! Authors: Lawrence T. Campbell
! License: BSD-3-Clause

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Module containing routines dealing with the interpolation of the
!> macroparticles to the 1D field mesh.

module FiElec1D

use paratype
use globals
use parafield

implicit none

contains

subroutine getInterps_1D(sz2)!, li1,li2)

use rhs_vars

real(kind=wp), intent(in) :: sz2(:)
!real(kind=wp), intent(out) :: li1, li2

integer(kind=ip) :: z2node
integer(kind=ipl) :: i

real(kind=wp) :: locz2

!$OMP DO PRIVATE(z2node, locz2)
  do i = 1, procelectrons_G(1)
  !do i = 1, maxEl
!    if (i<=procelectrons_G(1)) then

!                  Get surrounding nodes

      z2node = floor(sz2(i)  / dz2)  + 1_IP
      locz2 = sz2(i) - REAL(z2node  - 1_IP, kind=wp) * dz2

      if (fieldMesh == itemporal) then
        if (z2node >= NZ2_G) then
          print*, 'Z2 coord is too large!! with node:', z2node, &
                  ' and pos ', sz2(i)
          STOP
        end if
      end if

      if (z2node >= bz2) then
        qPArrOK_G = .false.
      end if

      lis_GR(1,i) = (1.0_wp - locz2/dz2)
      lis_GR(2,i) = 1 - lis_GR(1,i)

!    end if
  end do
!$OMP END DO

end subroutine getInterps_1D

!      ##################################################

subroutine getFFelecs_1D(sAr, sAi)

use rhs_vars

real(kind=wp), intent(in) :: sAr(:), sAi(:)
integer(kind=ip) :: i
integer error

!$OMP DO
  do i = 1, procelectrons_G(1)
!  do i = 1, maxEl

    !if (i<=procelectrons_G(1)) then

      sField4ElecReal(i) = lis_GR(1,i) * sAr(p_nodes(i)) + sField4ElecReal(i)
      sField4ElecReal(i) = lis_GR(2,i) * sAr(p_nodes(i) + 1_ip) + sField4ElecReal(i)

  end do
!$OMP END DO

!$OMP DO
  do i = 1, procelectrons_G(1)

      sField4ElecImag(i) = lis_GR(1,i) * sAi(p_nodes(i)) + sField4ElecImag(i)
      sField4ElecImag(i) = lis_GR(2,i) * sAi(p_nodes(i) + 1_ip) + sField4ElecImag(i)

!if (tProcInfo_G%rank == 0) print*, i, sField4ElecImag(i), sAi(p_nodes(i)), sAi(p_nodes(i)+1), &
!                                  p_nodes(i), lis_GR(1,i), lis_GR(2,i)

    !end if

  end do
!$OMP END DO

end subroutine getFFelecs_1D

!         ########################################################

subroutine getSource_1D(sDADzr, sDADzi, spr, spi, sgam, seta)

use rhs_vars

real(kind=wp), intent(inout) :: sDADzr(:), sDADzi(:)
real(kind=wp), intent(in) :: spr(:), spi(:)
real(kind=wp), intent(in) :: sgam(:)
real(kind=wp), intent(in) :: seta

integer(kind=ipl) :: i
real(kind=wp) :: dadzRInst, dadzIInst, dadzCom

integer :: error

!$OMP WORKSHARE
dadz_w = (s_chi_bar_G/dV3) * (1 + seta * sp2 ) &
                        / sgam
!$OMP END WORKSHARE

!$OMP DO PRIVATE(dadzRInst, dadzIInst)
  do i = 1, procelectrons_G(1)

  ! do i = 1, maxEl

    !if (i<=procelectrons_G(1)) then

!                  Get 'instantaneous' dAdz

      !dadzRInst = ((s_chi_bar_G(i)/dV3) * (1 + seta * sp2(i) ) &
      !                  * spr(i) / sgam(i) )

      ! dadzCom = ((s_chi_bar_G(i)/dV3)

      dadzRInst = dadz_w(i) * spr(i)

      !$OMP ATOMIC
      sDADzr(p_nodes(i)) =                         &
        lis_GR(1,i) * dadzRInst + sDADzr(p_nodes(i))

      !$OMP ATOMIC
      sDADzr(p_nodes(i) + 1_ip) =                  &
        lis_GR(2,i) * dadzRInst + sDADzr(p_nodes(i) + 1_ip)

!                   Imaginary part

      !dadzIInst = ((s_chi_bar_G(i)/dV3) * (1 + seta * sp2(i) ) &
      !                  * spi(i) / sgam(i) )

      dadzIInst = dadz_w(i) * spi(i)

      !$OMP ATOMIC
      sDADzi(p_nodes(i)) =                             &
        lis_GR(1,i) * dadzIInst + sDADzi(p_nodes(i))

      !$OMP ATOMIC
      sDADzi(p_nodes(i) + 1_ip) =                      &
        lis_GR(2,i) * dadzIInst + sDADzi(p_nodes(i) + 1_ip)

    !end if

  end do
!$OMP END DO

end subroutine getSource_1D

end module FiElec1D


      SUBROUTINE simp3(a,mp,np,i1,k1,ip,kp)
      INTEGER i1,ip,k1,kp,mp,np
      REAL a(mp,np)
      INTEGER ii,kk
      REAL piv
      piv=1./a(ip+1,kp+1)
      do 12 ii=1,i1+1
        if(ii-1.ne.ip)then
          a(ii,kp+1)=a(ii,kp+1)*piv
          do 11 kk=1,k1+1
            if(kk-1.ne.kp)then
              a(ii,kk)=a(ii,kk)-a(ip+1,kk)*a(ii,kp+1)
            endif
11        continue
        endif
12    continue
      do 13 kk=1,k1+1
        if(kk-1.ne.kp)a(ip+1,kk)=-a(ip+1,kk)*piv
13    continue
      a(ip+1,kp+1)=piv
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/simp3.for


************************************************************************
*                              RUNSTA.FOR                              *
*                                                                      *
*  PROGRAM: SIMRAND I                                                  *
*  MODULE:  1.5.5                                                      *
*  DATE:    02/04/85                                                   *
*                                                                      *
*  THIS IS THE SUBROUTINE RUNSTA.  IT ACCUMULATES THE STATISTICS       *
*  FOR THE RUN.                                                        *
*                                                                      *
*----------------------------------------------------------------------*
*                      CONFIGURATION CHANGES                           *
*                                                                      *
*    DATE                   CHANGE                                     *
*                                                                      *
*  01/18/85  * ORIGINAL.                                               *
*  01/22/85  * MODULE 13: REPLACE PRMIN WITH PRMAX.                    *
*  01/29/85  * MODULE  1: JDIAG .EQ. 2                                 *
*            * MODULE 17: JDIAG .EQ. 2                                 *
*  02/04/85  * MODULE 10: IF ((JDIAG .EQ. 1) .AND. (MOD(IITR,100) ...  *
*            * MODULE 16: IF ((JDIAG .EQ. 1 .AND. MOD(IITR,100)) ...   *
*                                                                      *
************************************************************************

$TITLE:'RUNSTA.LST'
$DEBUG
$NOFLOATCALLS
$STORAGE:2

************************************************************************

      SUBROUTINE RUNSTA

************************************************************************

***** INITIALIZE.  {MODULE 1}

$INCLUDE:'INITIAL.FOR'

      IF (JDIAG .EQ. 2) THEN
         WRITE (*,100)
100      FORMAT (/1X,'  ENTER SUBROUTINE RUNSTA')
      ENDIF

***   {END MODULE 1}

***** START DO LOOP TO CALCULATE RUN STATISTICS.  {MODULE 2}

      DO 110 IP=1,NIP

*****    CALCULATE PMEAN(IP).  {MODULE 3}

         PMEAN(IP) = ((IITR-1)*PMEAN(IP) + PMIN(IP))/IITR

***      {END MODULE 3}

*****    CALCULATE PMIN2(IP).  {MODULE 4}

         PMIN2(IP) = PMIN2(IP) + PMIN(IP)**2

***      {END MODULE 4}

*****    CALCULATE PSDEV(IP).  {MODULE 5}

         IF (IITR .GT. 1) THEN
            PVAR(IP) = (PMIN2(IP) - IITR*PMEAN(IP)**2)/(IITR - 1)
         ENDIF

         PSDEV(IP) = SQRT(ABS(PVAR(IP)))

***      {END MODULE 5}

*****    DETERMINE MINIMUM TOTAL PRICE & MINIMUM STEP PRICES.
*****    {MODULE 6}

         IF ((IITR .EQ. 1) .OR. (PMIN(IP) .LT. PRMIN(IP))) THEN
            PRMIN(IP) = PMIN(IP)
         ENDIF

***      {END MODULE 6}

*****    DETERMINE MAXIMUM TOTAL PRICE & MAXIMUM STEP PRICES.
*****    {MODULE 7}

         IF ((IITR .EQ. 1) .OR. (PMIN(IP) .GT. PRMAX(IP))) THEN
            PRMAX(IP) = PMIN(IP)
         ENDIF

***      {END MODULE 7}

110   CONTINUE

***   END IP DO LOOP.  {MODULE 2}

***** CALCULATE RUN UTILITY FUNCTION VALUES.  {MODULE 8}

      DO 120 II=1,NII
         RUTIL(II) = ((IITR - 1)*RUTIL(II) + UTIL(II))/IITR
120   CONTINUE

***   {END MODULE 8}

***** CALCULATE CERTAINTY EQUIVALENTS.  {MODULE 9}

      DO 150 II=1,NII

         IF (RUTIL(II) .LT. 0.0) RUTIL(II) = 0.0
         IF (RUTIL(II) .GT. 1.0) RUTIL(II) = 1.0

         DO 130 ID=1,NID,2
            IID = ID
            IF (RUTIL(II) .GE. UDATA(II,ID+3)) GO TO 140
130      CONTINUE

140      CERTEQ(II) = CECOEF(II,IID)*RUTIL(II) + CECOEF(II,IID+1)

150   CONTINUE

***   {END MODULE 9}

***** WRITE PMEAN(IP).  {MODULE 10}

      IF ((JDIAG .EQ. 1) .AND. (MOD(IITR,100) .EQ. 0))
     *   WRITE  (*,160) PMEAN(NIP)

      IF (JDIAG .EQ. 2) THEN

         IF (NIP .LE. 5) THEN
            WRITE  (*,160) (PMEAN(IP),IP=1,NIP)
         ELSE
            WRITE  (*,160) (PMEAN(IP),IP=1,5)
            WRITE  (*,170) (PMEAN(IP),IP=6,NIP)
         ENDIF

160      FORMAT (1X,'PMEAN',3X,1P5E14.4)
170      FORMAT (1X,        8X,1P5E14.4)

      ENDIF

***   {END MODULE 10}

***** WRITE PSDEV(IP).  {MODULE 11}

      IF (JDIAG .EQ. 2) THEN

         IF (NIP .LE. 5) THEN
            WRITE  (*,180) (PSDEV(IP),IP=1,NIP)
         ELSE
            WRITE  (*,180) (PSDEV(IP),IP=1,5)
            WRITE  (*,190) (PSDEV(IP),IP=6,NIP)
         ENDIF

180      FORMAT (1X,'PSDEV',3X,1P5E14.4)
190      FORMAT (1X,        8X,1P5E14.4)

      ENDIF

***   {END MODULE 11}

***** WRITE PRMIN(IP).  {MODULE 12}

      IF (JDIAG .EQ. 2) THEN

         IF (NIP .LE. 5) THEN
            WRITE  (*,200) (PRMIN(IP),IP=1,5)
         ELSE
            WRITE  (*,200) (PRMIN(IP),IP=1,5)
            WRITE  (*,210) (PRMIN(IP),IP=6,NIP)
         ENDIF

200      FORMAT (1X,'PRMIN',3X,1P5E14.4)
210      FORMAT (1X,        8X,1P5E14.4)

      ENDIF

***   {END MODULE 12}

***** WRITE PRMAX(IP).  {MODULE 13}

      IF (JDIAG .EQ. 2) THEN

         IF (NIP .LE. 5) THEN
            WRITE  (*,220) (PRMAX(IP),IP=1,5)
         ELSE
            WRITE  (*,220) (PRMAX(IP),IP=1,5)
            WRITE  (*,230) (PRMAX(IP),IP=6,NIP)
         ENDIF

220      FORMAT (1X,'PRMAX',3X,1P5E14.4)
230      FORMAT (1X,        8X,1P5E14.4)

      ENDIF

***   {END MODULE 13}

***** WRITE RUTIL(II).  {MODULE 14}

      IF (JDIAG .EQ. 2) THEN

         IF (NII .LE. 5) THEN
            WRITE  (*,240) (RUTIL(II),II=1,NII)
         ELSE
            WRITE  (*,240) (RUTIL(II),II=1,5)
            WRITE  (*,250) (RUTIL(II),II=6,NII)
         ENDIF

240      FORMAT (1X,'RUTIL',3X,5F14.4)
250      FORMAT (1X,        8X,5F14.4)

      ENDIF

***   {END MODULE 14}

***** WRITE CERTEQ(II).  {MODULE 15}

      IF (JDIAG .EQ. 2) THEN

         IF (NII .LE. 5) THEN
            WRITE  (*,260) (CERTEQ(II),II=1,NII)
         ELSE
            WRITE  (*,260) (CERTEQ(II),II=1,5)
            WRITE  (*,270) (CERTEQ(II),II=6,NII)
         ENDIF

260      FORMAT (1X,'CERTEQ',2X,5F14.4)
270      FORMAT (1X,         8X,5F14.4)

      ENDIF

***   {END MODULE 15}

***** WRITE IHALT(IA).  {MODULE 16}

      IF ((JDIAG .EQ. 1 .AND. MOD(IITR,100) .EQ. 0) .OR.
     *    (JDIAG .EQ. 2)) THEN

         IF (NIA .LE. 10) THEN
            WRITE (*,280) (IHALT(IA),IA=1,NIA)
         ELSE
            WRITE (*,280) (IHALT(IA),IA=1,10)
            WRITE (*,290) (IHALT(IA),IA=11,NIA)
         ENDIF

280      FORMAT (1X,'IHALT',3X,10I5)
290      FORMAT (1X,        8X,10I5)

      ENDIF

***   {END MODULE 16}

***** EXIT FROM SUBROUTINE RUNSTA.  {MODULE 17}

      IF (JDIAG .EQ. 2) THEN
         WRITE (*,999)
999      FORMAT (1X,'  EXIT  SUBROUTINE RUNSTA')
      ENDIF

      RETURN

      END

***   {END MODULE 17}

***************************** RUNSTA.FOR *******************************


      real*4 function interp(ix, iy, xfrac, yfrac, rvs, iac, ioff)

c      integer*4 CMAX
c      parameter (CMAX = 7000)
      integer*4 ix, iy, n, first, iac, ioff
      real*8 xfrac, yfrac
      !real*4 rvs(0:2*iac-1,*)
      !the upper defination makes the index of the second dimension (row) start with 1
      !I change it as follows, as both dimensions require index starting with 0
      !1-JUN-2015, Cunren Liang
      real*4 rvs(0:2*iac-1,0:100000000)

      complex temp(8)
      real*4 xintp(0:65544)
      data first/1/
      save xintp, first

c*    we want to do a 8192 x (8-pt sinc) interpolation of the original data, choosing
c*    the resulting nearest neighbor.

      if(first .eq. 1) then
         call intp_coef_norm(8192,xintp)
         first = 0
      end if
      n = 0

      ifrac = 8 * nint(xfrac * 8192.)
c      write (*,*)  '1 ',frac,ifrac
      do i = iy - 3 , iy + 4
         n = n + 1
         temp(n) = cmplx(0.0,0.0)
         do k = -3 , 4
            temp(n) = temp(n)  + rvs(ix+k+ioff,i) * xintp(ifrac+k+3)
         end do
      enddo

      ifrac = 8 * nint(yfrac * 8192.)
c      write (*,*)  '2 ', frac,ifrac
      cinterp = cmplx(0.,0.)
      do k = -3 , 4
         cinterp = cinterp + temp(k+4) * xintp(ifrac+k+3)
      end do
      interp = real(cinterp)
      return
      end


!-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      real*8 qr(12), tau(3)

      character arg*32

      qr = (/ 1, -1, 4, 1, 4, -2, 1, 4, 2, 1, -1, 0 /)

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)
      call ceedqrfactorization(ceed,qr,tau,4,3,err);
      do i=1,12
        if (abs(qr(i))<1.0D-14) then
! LCOV_EXCL_START
          qr(i) = 0
! LCOV_EXCL_STOP
        endif
        write(*,'(A,F12.8)') '',qr(i)
      enddo
      do i=1,3
        if (abs(tau(i))<1.0D-14) then
! LCOV_EXCL_START
          tau(i) = 0
! LCOV_EXCL_STOP
        endif
        write(*,'(A,F12.8)') '',tau(i)
      enddo

      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


*DECK CG
      SUBROUTINE CG (NM, N, AR, AI, WR, WI, MATZ, ZR, ZI, FV1, FV2, FV3,
     +   IERR)
C***BEGIN PROLOGUE  CG
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a complex general matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A4
C***TYPE      COMPLEX (RG-S, CG-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a COMPLEX GENERAL matrix.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, AR, AI, ZR and ZI, as declared in the
C          calling program dimension statement.  NM is an INTEGER
C          variable.
C
C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        AR and AI contain the real and imaginary parts, respectively,
C          of the complex general matrix.  AR and AI are two-dimensional
C          REAL arrays, dimensioned AR(NM,N) and AI(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On OUTPUT
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues.  WR and WI are one-dimensional REAL
C          arrays, dimensioned WR(N) and WI(N).
C
C        ZR and ZI contain the real and imaginary parts, respectively,
C          of the eigenvectors if MATZ is not zero.  ZR and ZI are
C          two-dimensional REAL arrays, dimensioned ZR(NM,N) and
C          ZI(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30 iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
C                     computed.
C
C        FV1, FV2, and FV3 are one-dimensional REAL arrays used for
C          temporary storage, dimensioned FV1(N), FV2(N), and FV3(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  CBABK2, CBAL, COMQR, COMQR2, CORTH
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CG
C
      INTEGER N,NM,IS1,IS2,IERR,MATZ
      REAL AR(NM,*),AI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*)
      REAL FV1(*),FV2(*),FV3(*)
C
C***FIRST EXECUTABLE STATEMENT  CG
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 CALL  CBAL(NM,N,AR,AI,IS1,IS2,FV1)
      CALL  CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
   50 RETURN
      END


      SUBROUTINE SELBO2 (TI)
C
C     THIS ROUTINE IS THE PHASE II SUBROUTINE OF STRESS DATA RECOVERY
C     FOR THE BEAM ELEMENT.
C
      INTEGER         TLOADS
      REAL            I1,I2,L,M1A,M2A,M1B,M2B,I12,K1A,K2A,K1B,K2B,
     1                TI(14),M2BT
      EQUIVALENCE     (LDTEMP,TEMPLD),(MSTEN,SMTEN),(MSCOM,SMCOM)
      COMMON /ZZZZZZ/ ZZ(1)
      COMMON /SDR2X4/ XXXXXX(33),ICSTM,NCSTM,IVEC,IVECN,LDTEMP,ELDEFM,
     1                DUM8(8),TLOADS
C
C     THE FIRST 100 LOCATIONS OF THE SDR2X7 BLOCK ARE RESERVED FOR INPUT
C     PARAMETERS, THE SECOND 100 FOR STRESS OUTPUT PARAMETERS, AND FORCE
C     OUTPUT PARAMETERS BEGIN AT LOCATION 201.
C
      COMMON /SDR2X7/ JELID,JSILNO(2),SA(36),SB(36),ST,SDELTA,A,FJ,I1,
     1                I2,C,R1,T1,R2,T2,R3,T3,R4,T4,T SUB 0,SIGMAT,
     2                SIGMAC,L,R,BETAR,THERM(4)
      COMMON /SDR2X7/ ISELID,SIG1A,SIG2A,SIG3A,SIG4A,SIGAX,SIGAMX,
     3                SIGAMN,MSTEN,SIG1B,SIG2B,SIG3B,SIG4B,SIGBX,
     4                SIGBMX,SIGBMN,MSCOM,YYYYYY(83)
      COMMON /SDR2X7/ IFELID,M1A,M2A,V1,V2,FX,T,M1B,M2BT,V1BT,FXBT,TBT
C
      COMMON /SDR2X8/ FA(6),FB(6),IDISP,IUA,IUB,P1,K1A,K2A,K1B,K2B,Q,W
      DATA    DCR   / .017453292 /
C
      SID(X) = SIN(X*DCR)
      COD(X) = COS(X*DCR)
C
      X   = 1.0
      YL  = R*(1.-COD(BETAR))
      XL  = R*SID(BETAR)
      I12 = 0.
      IDISP = IVEC - 1
      IUA = IDISP + JSILNO(1)
      CALL GMMATS (SA(1),6,6,0, ZZ(IUA),6,1,0, FA(1))
      IUB = IDISP + JSILNO(2)
      CALL GMMATS (SB(1),6,6,0, ZZ(IUB),6,1,0, FB(1))
      FX  = -FA(1) - FB(1)
      V1  = -FA(2) - FB(2)
      V2  = -FA(3) - FB(3)
      T   = -FA(4) - FB(4)
      M2A =  FA(5) + FB(5)
      M1A = -FA(6) - FB(6)
C
C     IF LDTEMP = -1, THE LOADING TEMPERATURE IS UNDEFINED
C
      IF (TLOADS .EQ. 0) GO TO 10
      TBAR = TI(1)
      DT   = TBAR - TSUB0
      DO 5 I = 1,6
      FA(I) = DT*THERM(I)
    5 CONTINUE
      FX  = FX  + FA(1)
      V1  = V1  + FA(2)
      M1A = M1A + FA(6)
10    M1B = M1A - V1*XL + FX*YL
      M2B = M2A - V2*XL
      TB  = T   - V2*YL
C
C     TRANSFORM FORCES AT B-END TO A COORD. SYS TANGENT TO B-END
C
      FXBT = V1*SID(BETAR) + FX*ABS(COD(BETAR))
      V1BT = V1*ABS(COD(BETAR))  - FX*SID(BETAR)
      M2BT = M2B*ABS(COD(BETAR)) + TB*SID(BETAR)
      TBT  =-M2B*SID(BETAR) + TB*ABS(COD(BETAR))
C
C     COMPUTE ELEMENT STRESSES AT 4 POINTS
C
C
C     COMPUTE K1A AND K2A
C
      IF (I12 .NE. 0.0) GO TO 30
      IF (I1  .NE. 0.0) GO TO 20
      K1A = 0.0
      GO TO 40
   20 K1A = -M1A/I1
      GO TO 40
   30 K1A = (M2A*I12 - M1A*I2)/(I1*I2 - I12**2)
      K2A = (M1A*I12 - M2A*I1)/(I1*I2 - I12**2)
      GO TO 60
   40 IF (I2 .NE. 0.0) GO TO 50
      K2A = 0.0
      GO TO 60
   50 K2A = -M2A/I2
C
C     CHANGE STRESS RECOVERY CONSTANTS FROM CYL. TO RECT. COORD.
C
      C1 = R1*SID(T1)
      C2 = R1*COD(T1)
      D1 = R2*SID(T2)
      D2 = R2*COD(T2)
      F1 = R3*SID(T3)
      F2 = R3*COD(T3)
      G1 = R4*SID(T4)
      G2 = R4*COD(T4)
C
C     COMPUTE SIG1A, SIG2A, SIG3A AND SIG4A
C
   60 SIG1A = K1A*C1*C + K2A*C2
      SIG2A = K1A*D1*C + K2A*D2
      SIG3A = K1A*F1*C + K2A*F2
      SIG4A = K1A*G1*C + K2A*G2
C
C     COMPUTE K1B AND K2B
C
      IF (I12 .NE. 0.0) GO TO 80
      IF (I1  .NE. 0.0) GO TO 70
      K1B = 0.0
      GO TO 90
   70 K1B = -M1B/I1
      GO TO 90
   80 K1B = (M2BT*I12 - M1B *I2)/(I1*I2 - I12**2)
      K2B = (M1B *I12 - M2BT*I1)/(I1*I2 - I12**2)
      GO TO 110
   90 IF (I2 .NE. 0.0) GO TO 100
      K2B = 0.0
      GO TO 110
  100 K2B = -M2BT/I2
C
C     COMPUTE SIG1B, SIG2B, SIG3B AND SIG4B
C
  110 SIG1B = K1B*C1*C + K2B*C2
      SIG2B = K1B*D1*C + K2B*D2
      SIG3B = K1B*F1*C + K2B*F2
      SIG4B = K1B*G1*C + K2B*G2
      IF (TLOADS .EQ. 0) GO TO 115
C
C     TEST IF AT LEAST ONE POINT TEMPERATURE IS GIVEN
C
      DO 111 I = 7,14
      IF (TI(I) .NE. 0.0) GO TO 112
  111 CONTINUE
      GO TO 115
  112 IF (A .EQ. 0.0) GO TO 115
      EALF  =-ST/A
      SIG1A = SIG1A + EALF*(TI( 7) - TI(3)*C1*C - TI(5)*C2 - TI(1))
      SIG2A = SIG2A + EALF*(TI( 8) - TI(3)*D1*C - TI(5)*D2 - TI(1))
      SIG3A = SIG3A + EALF*(TI( 9) - TI(3)*F1*C - TI(5)*F2 - TI(1))
      SIG4A = SIG4A + EALF*(TI(10) - TI(3)*G1*C - TI(5)*G2 - TI(1))
      SIG1B = SIG1B + EALF*(TI(11) - TI(4)*C1*C - TI(6)*C2 - TI(2))
      SIG2B = SIG2B + EALF*(TI(12) - TI(4)*D1*C - TI(6)*D2 - TI(2))
      SIG3B = SIG3B + EALF*(TI(13) - TI(4)*F1*C - TI(6)*F2 - TI(2))
      SIG4B = SIG4B + EALF*(TI(14) - TI(4)*G1*C - TI(6)*G2 - TI(2))
  115 CONTINUE
C
C     COMPUTE AXIAL STRESS
C
      SIGAX = 0.0
      SIGBX = 0.0
      IF (A .NE. 0.0) SIGAX = FX/A
      IF (A .NE. 0.0) SIGBX = FXBT/A
C
C     COMPUTE MAXIMA AND MINIMA
C
      SIGAMX = SIGAX + AMAX1(SIG1A,SIG2A,SIG3A,SIG4A)
      SIGBMX = SIGBX + AMAX1(SIG1B,SIG2B,SIG3B,SIG4B)
      SIGAMN = SIGAX + AMIN1(SIG1A,SIG2A,SIG3A,SIG4A)
      SIGBMN = SIGBX + AMIN1(SIG1B,SIG2B,SIG3B,SIG4B)
C
C     COMPUTE MARGIN OF SAFETY IN TENSION
C
      IF (SIGMAT .LE. 0.0) GO TO 620
      IF (AMAX1(SIGAMX,SIGBMX) .LE. 0.0) GO TO 620
      Q = SIGMAT/AMAX1(SIGAMX,SIGBMX)
      SMTEN = Q - 1.0
      GO TO 630
  620 MSTEN = 1
C
C     COMPUTE MARGIN OF SAFETY IN COMPRESSION
C
  630 IF (SIGMAC .LE. 0.0) GO TO 640
      IF (AMIN1(SIGAMN,SIGBMN) .GE. 0.0) GO TO 640
      W = -SIGMAC/AMIN1(SIGAMN,SIGBMN)
      SMCOM  = W - 1.0
      GO TO 150
  640 MSCOM  = 1
  150 ISELID = JELID
      IFELID = JELID
      RETURN
      END


subroutine setaux1d(ixyz,mbc,mx1,maxm,x1lower,x2val,x3val,dx1,dx2,dx3,t,maux,aux,iout)

    ! set auxiliary variables in current row with direction specified by ixyz
    !
    ! ixyz = 1 => row in x direction, e2 is y direction, e3 is z direction
    ! ixyz = 2 => row in y direction, e2 is z direction, e3 is x direction
    ! ixyz = 3 => row in z direction, e2 is x direction, e3 is y direction
    !
    ! Auxiliary variables:
    !       1 rho
    !       2 lambda
    !       3 mu
    !       4 cp
    !       5 cs
    !       6 slip (obtained from 2d aux in step3.f)
    !       7 nx at lower wall in e1 direction
    !       8 ny at lower wall in e1 direction
    !       9 nz at lower wall in e1 direction
    !       10 area ratio of lower wall in e1 direction
    !       11 nx at lower wall in e2 direction
    !       12 ny at lower wall in e2 direction
    !       13 nz at lower wall in e2 direction
    !       14 area ratio of lower wall in e2 direction
    !       15 nx at lower wall in e3 direction
    !       16 ny at lower wall in e3 direction
    !       17 nz at lower wall in e3 direction
    !       18 area ratio of lower wall in e3 direction

    implicit none
    integer, intent(in) :: ixyz,mbc,mx1,maxm,maux,iout
    real(kind=8), intent(in) :: x1lower,x2val,x3val,dx1,dx2,dx3,t
    real(kind=8), intent(out) ::  aux(maux,1-mbc:maxm+mbc,3)

    real(kind=8) :: x1cell, cp, cs, rho_cell, lambda_cell, mu_cell
    real(kind=8) :: x1ccorn(4), x2ccorn(4), x3ccorn(4)
    real(kind=8) :: x1pcorn(4), x2pcorn(4), x3pcorn(4), mag
    real(kind=8) :: nx1, nx2, nx3
    integer :: i

    lambda_cell = 60.d9  ! Pa
    mu_cell = 30.d9      ! Pa
    rho_cell = 2500.d0   ! kg/m**3
    cp = dsqrt((lambda_cell + 2.d0*mu_cell)/rho_cell)
    cs = dsqrt(mu_cell/rho_cell)

    do i=1-mbc,mx1 + mbc
      x1cell = x1lower + (i-0.5d0)*dx1
      aux(1,i,iout) = rho_cell
      aux(2,i,iout) = lambda_cell
      aux(3,i,iout) = mu_cell
      aux(4,i,iout) = cp
      aux(5,i,iout) = cs

      ! compute mapping info for lower face in e1 direction
      x1ccorn(1) = x1cell - 0.5d0*dx1 ! p1 dot e1
      x2ccorn(1) = x2val - 0.5d0*dx2  ! p1 dot e2
      x3ccorn(1) = x3val - 0.5d0*dx3  ! p1 dot e3

      x1ccorn(2) = x1cell - 0.5d0*dx1 ! p2 dot e1
      x2ccorn(2) = x2val - 0.5d0*dx2  ! p2 dot e2
      x3ccorn(2) = x3val + 0.5d0*dx3  ! p2 dot e3

      x1ccorn(3) = x1cell - 0.5d0*dx1 ! p3 dot e1
      x2ccorn(3) = x2val + 0.5d0*dx2  ! p3 dot e2
      x3ccorn(3) = x3val + 0.5d0*dx3  ! p3 dot e3

      x1ccorn(4) = x1cell - 0.5d0*dx1 ! p4 dot e1
      x2ccorn(4) = x2val + 0.5d0*dx2  ! p4 dot e2
      x3ccorn(4) = x3val - 0.5d0*dx3  ! p4 dot e3
      if (ixyz == 1) then
        call mapc2p(x1ccorn(1), x2ccorn(1), x3ccorn(1), x1pcorn(1), x2pcorn(1), x3pcorn(1))
        call mapc2p(x1ccorn(2), x2ccorn(2), x3ccorn(2), x1pcorn(2), x2pcorn(2), x3pcorn(2))
        call mapc2p(x1ccorn(3), x2ccorn(3), x3ccorn(3), x1pcorn(3), x2pcorn(3), x3pcorn(3))
        call mapc2p(x1ccorn(4), x2ccorn(4), x3ccorn(4), x1pcorn(4), x2pcorn(4), x3pcorn(4))
      else if (ixyz == 2) then
        call mapc2p(x3ccorn(1), x1ccorn(1), x2ccorn(1), x3pcorn(1), x1pcorn(1), x2pcorn(1))
        call mapc2p(x3ccorn(2), x1ccorn(2), x2ccorn(2), x3pcorn(2), x1pcorn(2), x2pcorn(2))
        call mapc2p(x3ccorn(3), x1ccorn(3), x2ccorn(3), x3pcorn(3), x1pcorn(3), x2pcorn(3))
        call mapc2p(x3ccorn(4), x1ccorn(4), x2ccorn(4), x3pcorn(4), x1pcorn(4), x2pcorn(4))
      else if (ixyz == 3) then
        call mapc2p(x2ccorn(1), x3ccorn(1), x1ccorn(1), x2pcorn(1), x3pcorn(1), x1pcorn(1))
        call mapc2p(x2ccorn(2), x3ccorn(2), x1ccorn(2), x2pcorn(2), x3pcorn(2), x1pcorn(2))
        call mapc2p(x2ccorn(3), x3ccorn(3), x1ccorn(3), x2pcorn(3), x3pcorn(3), x1pcorn(3))
        call mapc2p(x2ccorn(4), x3ccorn(4), x1ccorn(4), x2pcorn(4), x3pcorn(4), x1pcorn(4))
      end if

      nx1 = (x2pcorn(3) - x2pcorn(1))*(x3pcorn(2) - x3pcorn(4)) - (x2pcorn(2) - x2pcorn(4))*(x3pcorn(3) - x3pcorn(1))
      nx2 = (x1pcorn(2) - x1pcorn(4))*(x3pcorn(3) - x3pcorn(1)) - (x1pcorn(3) - x1pcorn(1))*(x3pcorn(2) - x3pcorn(4))
      nx3 = (x1pcorn(3) - x1pcorn(1))*(x2pcorn(2) - x2pcorn(4)) - (x1pcorn(2) - x1pcorn(4))*(x2pcorn(3) - x2pcorn(1))
      mag = dsqrt(nx1*nx1 + nx2*nx2 + nx3*nx3)
      nx1 = nx1/mag
      nx2 = nx2/mag
      nx3 = nx3/mag

      if (ixyz == 1) then
        aux(7,i,iout) = nx1
        aux(8,i,iout) = nx2
        aux(9,i,iout) = nx3
      else if (ixyz == 2) then
        aux(7,i,iout) = nx3
        aux(8,i,iout) = nx1
        aux(9,i,iout) = nx2
      else if (ixyz == 3) then
        aux(7,i,iout) = nx2
        aux(8,i,iout) = nx3
        aux(9,i,iout) = nx1
      end if

      aux(10,i,iout) = 0.5d0*mag/(dx2*dx3)

      ! compute mapping info for lower face in e2 direction
      x1ccorn(1) = x1cell - 0.5d0*dx1 ! p1 dot e1
      x2ccorn(1) = x2val - 0.5d0*dx2  ! p1 dot e2
      x3ccorn(1) = x3val - 0.5d0*dx3  ! p1 dot e3

      x1ccorn(2) = x1cell + 0.5d0*dx1 ! p2 dot e1
      x2ccorn(2) = x2val - 0.5d0*dx2  ! p2 dot e2
      x3ccorn(2) = x3val - 0.5d0*dx3  ! p2 dot e3

      x1ccorn(3) = x1cell + 0.5d0*dx1 ! p3 dot e1
      x2ccorn(3) = x2val - 0.5d0*dx2  ! p3 dot e2
      x3ccorn(3) = x3val + 0.5d0*dx3  ! p3 dot e3

      x1ccorn(4) = x1cell - 0.5d0*dx1 ! p4 dot e1
      x2ccorn(4) = x2val - 0.5d0*dx2  ! p4 dot e2
      x3ccorn(4) = x3val + 0.5d0*dx3  ! p4 dot e3
      if (ixyz == 1) then
        call mapc2p(x1ccorn(1), x2ccorn(1), x3ccorn(1), x1pcorn(1), x2pcorn(1), x3pcorn(1))
        call mapc2p(x1ccorn(2), x2ccorn(2), x3ccorn(2), x1pcorn(2), x2pcorn(2), x3pcorn(2))
        call mapc2p(x1ccorn(3), x2ccorn(3), x3ccorn(3), x1pcorn(3), x2pcorn(3), x3pcorn(3))
        call mapc2p(x1ccorn(4), x2ccorn(4), x3ccorn(4), x1pcorn(4), x2pcorn(4), x3pcorn(4))
      else if (ixyz == 2) then
        call mapc2p(x3ccorn(1), x1ccorn(1), x2ccorn(1), x3pcorn(1), x1pcorn(1), x2pcorn(1))
        call mapc2p(x3ccorn(2), x1ccorn(2), x2ccorn(2), x3pcorn(2), x1pcorn(2), x2pcorn(2))
        call mapc2p(x3ccorn(3), x1ccorn(3), x2ccorn(3), x3pcorn(3), x1pcorn(3), x2pcorn(3))
        call mapc2p(x3ccorn(4), x1ccorn(4), x2ccorn(4), x3pcorn(4), x1pcorn(4), x2pcorn(4))
      else if (ixyz == 3) then
        call mapc2p(x2ccorn(1), x3ccorn(1), x1ccorn(1), x2pcorn(1), x3pcorn(1), x1pcorn(1))
        call mapc2p(x2ccorn(2), x3ccorn(2), x1ccorn(2), x2pcorn(2), x3pcorn(2), x1pcorn(2))
        call mapc2p(x2ccorn(3), x3ccorn(3), x1ccorn(3), x2pcorn(3), x3pcorn(3), x1pcorn(3))
        call mapc2p(x2ccorn(4), x3ccorn(4), x1ccorn(4), x2pcorn(4), x3pcorn(4), x1pcorn(4))
      end if

      nx1 = (x2pcorn(3) - x2pcorn(1))*(x3pcorn(2) - x3pcorn(4)) - (x2pcorn(2) - x2pcorn(4))*(x3pcorn(3) - x3pcorn(1))
      nx2 = (x1pcorn(2) - x1pcorn(4))*(x3pcorn(3) - x3pcorn(1)) - (x1pcorn(3) - x1pcorn(1))*(x3pcorn(2) - x3pcorn(4))
      nx3 = (x1pcorn(3) - x1pcorn(1))*(x2pcorn(2) - x2pcorn(4)) - (x1pcorn(2) - x1pcorn(4))*(x2pcorn(3) - x2pcorn(1))
      mag = dsqrt(nx1*nx1 + nx2*nx2 + nx3*nx3)
      nx1 = nx1/mag
      nx2 = nx2/mag
      nx3 = nx3/mag

      if (ixyz == 1) then
        aux(11,i,iout) = nx1
        aux(12,i,iout) = nx2
        aux(13,i,iout) = nx3
      else if (ixyz == 2) then
        aux(11,i,iout) = nx3
        aux(12,i,iout) = nx1
        aux(13,i,iout) = nx2
      else if (ixyz == 3) then
        aux(11,i,iout) = nx2
        aux(12,i,iout) = nx3
        aux(13,i,iout) = nx1
      end if

      aux(14,i,iout) = 0.5d0*mag/(dx1*dx3)

      ! compute mapping info for lower face in e3 direction
      x1ccorn(1) = x1cell - 0.5d0*dx1 ! p1 dot e1
      x2ccorn(1) = x2val - 0.5d0*dx2  ! p1 dot e2
      x3ccorn(1) = x3val - 0.5d0*dx3  ! p1 dot e3

      x1ccorn(2) = x1cell - 0.5d0*dx1 ! p2 dot e1
      x2ccorn(2) = x2val + 0.5d0*dx2  ! p2 dot e2
      x3ccorn(2) = x3val - 0.5d0*dx3  ! p2 dot e3

      x1ccorn(3) = x1cell + 0.5d0*dx1 ! p3 dot e1
      x2ccorn(3) = x2val + 0.5d0*dx2  ! p3 dot e2
      x3ccorn(3) = x3val - 0.5d0*dx3  ! p3 dot e3

      x1ccorn(4) = x1cell + 0.5d0*dx1 ! p4 dot e1
      x2ccorn(4) = x2val - 0.5d0*dx2  ! p4 dot e2
      x3ccorn(4) = x3val - 0.5d0*dx3  ! p4 dot e3
      if (ixyz == 1) then
        call mapc2p(x1ccorn(1), x2ccorn(1), x3ccorn(1), x1pcorn(1), x2pcorn(1), x3pcorn(1))
        call mapc2p(x1ccorn(2), x2ccorn(2), x3ccorn(2), x1pcorn(2), x2pcorn(2), x3pcorn(2))
        call mapc2p(x1ccorn(3), x2ccorn(3), x3ccorn(3), x1pcorn(3), x2pcorn(3), x3pcorn(3))
        call mapc2p(x1ccorn(4), x2ccorn(4), x3ccorn(4), x1pcorn(4), x2pcorn(4), x3pcorn(4))
      else if (ixyz == 2) then
        call mapc2p(x3ccorn(1), x1ccorn(1), x2ccorn(1), x3pcorn(1), x1pcorn(1), x2pcorn(1))
        call mapc2p(x3ccorn(2), x1ccorn(2), x2ccorn(2), x3pcorn(2), x1pcorn(2), x2pcorn(2))
        call mapc2p(x3ccorn(3), x1ccorn(3), x2ccorn(3), x3pcorn(3), x1pcorn(3), x2pcorn(3))
        call mapc2p(x3ccorn(4), x1ccorn(4), x2ccorn(4), x3pcorn(4), x1pcorn(4), x2pcorn(4))
      else if (ixyz == 3) then
        call mapc2p(x2ccorn(1), x3ccorn(1), x1ccorn(1), x2pcorn(1), x3pcorn(1), x1pcorn(1))
        call mapc2p(x2ccorn(2), x3ccorn(2), x1ccorn(2), x2pcorn(2), x3pcorn(2), x1pcorn(2))
        call mapc2p(x2ccorn(3), x3ccorn(3), x1ccorn(3), x2pcorn(3), x3pcorn(3), x1pcorn(3))
        call mapc2p(x2ccorn(4), x3ccorn(4), x1ccorn(4), x2pcorn(4), x3pcorn(4), x1pcorn(4))
      end if

      nx1 = (x2pcorn(3) - x2pcorn(1))*(x3pcorn(2) - x3pcorn(4)) - (x2pcorn(2) - x2pcorn(4))*(x3pcorn(3) - x3pcorn(1))
      nx2 = (x1pcorn(2) - x1pcorn(4))*(x3pcorn(3) - x3pcorn(1)) - (x1pcorn(3) - x1pcorn(1))*(x3pcorn(2) - x3pcorn(4))
      nx3 = (x1pcorn(3) - x1pcorn(1))*(x2pcorn(2) - x2pcorn(4)) - (x1pcorn(2) - x1pcorn(4))*(x2pcorn(3) - x2pcorn(1))
      mag = dsqrt(nx1*nx1 + nx2*nx2 + nx3*nx3)
      nx1 = nx1/mag
      nx2 = nx2/mag
      nx3 = nx3/mag

      if (ixyz == 1) then
        aux(15,i,iout) = nx1
        aux(16,i,iout) = nx2
        aux(17,i,iout) = nx3
      else if (ixyz == 2) then
        aux(15,i,iout) = nx3
        aux(16,i,iout) = nx1
        aux(17,i,iout) = nx2
      else if (ixyz == 3) then
        aux(15,i,iout) = nx2
        aux(16,i,iout) = nx3
        aux(17,i,iout) = nx1
      end if

      aux(18,i,iout) = 0.5d0*mag/(dx1*dx2)

    end do

end subroutine setaux1d


C++------------------------------------------------------------------
C
C       PROGRAM TO COMPUTE THE SHELL DIAGRAM FROM
C       THE PERIOD/RMAX DATA
C
C
C RADIUS (input)
C PERIOD (input)
C
C ZRS (output) :
C      ZRS(MM,1)=Radius of shell MM with r1/4 plus halo
C      ZRS(MM,2)=Radius of shell MM if keplerian only
C ZANUM (intermediate) :
C      ZANUM(MM,1)=MM-PHF+TAU-1
C      ZANUM(MM,2)=MM-PHF
C
C P. J. Quinn  Sept. 1987
C Revised JLP  28-01-88
C------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (A-H,O-Y)
	REAL*8 PERIOD(1000),RADIUS(1000)
	REAL*4 ZANUM(1000,2),ZRS(1000,2)
C
C Read unit 9 (Parameters)
	PRINT *,' Reading FOR009.DAT  (parameters)'
	OPEN(9,FILE='FOR009.DAT',STATUS='OLD')
        READ(9,*)GM1,GAMMA1,CHI,GM2,GAMMA2
	CLOSE(9)

C Read unit 10 (period-apocentre table)
	PRINT *,' Reading FOR010.DAT  (period-apocentre table)'
	OPEN(10,FILE='FOR010.DAT',STATUS='OLD')
        READ(10,*,END=20)(PERIOD(KK),RADIUS(KK),KK=1,1000)
20	KK=KK-1
        PMIN=PERIOD(1)
        RMIN=RADIUS(1)
	CLOSE(10)

C Open unit 11 (output table with shell parameters)
	OPEN(11,FILE=' SHELLS.SQI',STATUS='NEW')
 303    FORMAT(15X,4F12.6)
        WRITE(11,209)GM1,GAMMA1,CHI,GM2,GAMMA2
 209    FORMAT(' HALO MASS (GM1) AND GAMMA1, CHI (R_CUT/GAMMA_HALO),'
     1	' ELLIPTICAL MASS (GM2) AND GAMMA2',/,
     1	15X,5F12.6,/,
     1	' SHELL #, RADIUS, RADIUS (IF ONLY KEPLERIAN),',
     1	' LOG10(RADIUS), LOG(M-PHI+TAU-1),SLOPE (LOG/LOG PLANE)',/)

C Prompt some information to the user:
        WRITE(6,222)
 222    FORMAT(1X,'SHELLS>> NUMBER OF SHELLS   : '$)
        READ(5,*)NSHELL
C Increase NSHELL by 1 (otherwise one shell is missing...)
        NSHELL=NSHELL+1

	MM=NSHELL
        WRITE(6,223)
 223    FORMAT(1X,'SHELLS>> PHASE FACTOR       : '$)
        READ(5,*)PHF
        WRITE(6,999)
 999    FORMAT(1x,'SHELLS>> Tau                : '$)
        READ(5,*)tau

C Main loop
	MM=NSHELL
94	IF(MM.LE.1) GOTO 95

C Looking for the right period (TIME) in the array PERIOD
	TIME=((FLOAT(NSHELL)-PHF+tau-1.)/
     1	(FLOAT(MM)-PHF+tau-1.))*PMIN

	DO I=1,KK
	  IF(TIME.GE.PERIOD(I).AND.TIME.LT.PERIOD(I+1))GOTO 10
	END DO

	PRINT *,' FATAL ERROR'
	PRINT *,' The table of the periods is not complete'
	STOP

C When the nearest period is found :
10	SLOPE=(RADIUS(I+1)-RADIUS(I))/(PERIOD(I+1)-PERIOD(I))
        RR=RADIUS(I)+SLOPE*(TIME-PERIOD(I))
        ZRS(MM,1)=RR
        AN=NSHELL
        AM=MM
        ZRS(MM,2)=rmin*((float(NSHELL)-phf+tau-1.)/
     &                   (float(mm)-phf+tau-1.))**(2./3.)
        ZANUM(MM,1)=MM-PHF+tau-1
        AZX=ALOG(ZRS(MM,1))
        ALZ=ALOG(ZANUM(MM,1))
        IF(MM.EQ.NSHELL)THEN
          SLOPE=0
        ELSE
          SLOPE=(ALOG(ZRS(MM+1,1))-AZX)/(ALOG(ZANUM(MM+1,1))-ALZ)
        END IF
	WRITE(11,107)MM,ZRS(MM,1),ZRS(MM,2),AZX,ALZ,SLOPE
 107    FORMAT(15X,I3,5F12.6)
        ZANUM(MM,2)=MM-PHF
        MM=MM-1

	GOTO 94

95	CLOSE(9)
	CLOSE(10)
	CLOSE(11)
	PRINT *,' Output in SHELLS.SQI'
	END


program ch0810
    ! Rank 1 Whole Arrays in Fortran
    implicit none

    integer , parameter :: n = 12
    real, dimension(1:n) :: rainfall_ins = 0.
    real, dimension(1:n) :: rainfall_cms = 0.
    integer :: month

    print *, &
        ' Input the rainfall values in inches'
    read *, rainfall_ins
    rainfall_cms = rainfall_ins*2.54
    do month = 1, n
        print *, ' ', month, ' ', rainfall_ins(month &
            ), ' ', rainfall_cms(month)
    end do
end program


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C BenchIT - Performance Measurement for Scientific Applications
C Contact: developer@benchit.org
C
C $Id: vecadd.f 1 2009-09-11 12:26:19Z william $
C $URL: svn+ssh://william@rupert.zih.tu-dresden.de/svn-base/benchit-root/BenchITv6/kernel/numerical/vecadd/F77/0/0/BjxxEBjxxPAi/vecadd.f $
C For license details see COPYING in the package base directory
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C This is the actual measuring function. It adds two vectors.
C Solving the equation: b(jxx)=b(jxx)+a(i)
C ***
      subroutine vecadd(n, m, unroll, a, b)
      Integer n, m, unroll
      REAL*8 a( n ), b( n )

      Integer i11, j1, j2, i, j

C     **** Initialization
      i11 = 0
      j1 = 0
      j2 = 0
      i = 0
      j = 0

      if ( unroll.eq.1 ) then
         Do i11 = 1, m
            do j = 1, n
               do i = 1, n
                  b( j ) = b( j ) + a( i )
               end do
            end do
         enddo
      else
         Do i11 = 1, m
            j1 = 1
            j2 = MOD( n, unroll )
            do j = 1, j2
               do i= 1, n
                  b( j ) = b( j ) + a( i )
               end do
               j1 = j1 + 1
            enddo
         enddo
         if ( unroll.eq.2 ) then
           Do i11 = 1, m
             do j = j1, n, 2
                 do i = 1, n
                    b( j )   = b( j )   + a( i )
                    b( j+1 ) = b( j+1 ) + a( i )
                 end do
              end do
           enddo
         elseif ( unroll.eq.3 ) then
            Do i11 = 1, m
               do j = j1, n, 3
                  do i = 1, n
                     b( j )   = b( j )   + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.4 ) then
            Do i11 = 1, m
               do j = j1, n, 4
                  do i = 1, n
                     b( j )   = b( j )   + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.5 ) then
            Do i11 = 1, m
               do j = j1, n, 5
                  do i = 1, n
                     b( j )   = b( j )   + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.6 ) then
            Do i11 = 1, m
               do j = j1, n, 6
                  do i = 1, n
                     b( j )   = b( j )   + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.7 ) then
            Do i11 = 1, m
               do j = j1, n, 7
                  do i = 1, n
                     b( j )   = b( j )   + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.8 ) then
            Do i11 = 1, m
               do j = j1, n, 8
                  do i = 1, n
                     b( j )   = b( j )   + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.9 ) then
            Do i11 = 1, m
               do j = j1, n, 9
                  do i = 1, n
                     b( j   ) = b( j   ) + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                     b( j+8 ) = b( j+8 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.10 ) then
            Do i11 = 1, m
               do j = j1, n, 10
                  do i = 1, n
                     b( j   ) = b( j   ) + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                     b( j+8 ) = b( j+8 ) + a( i )
                     b( j+9 ) = b( j+9 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.11 ) then
            Do i11 = 1, m
               do j = j1, n, 11
                  do i = 1, n
                     b( j   ) = b( j   ) + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                     b( j+8 ) = b( j+8 ) + a( i )
                     b( j+9 ) = b( j+9 ) + a( i )
                     b( j+10 ) = b( j+10 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.12 ) then
            Do i11 = 1, m
               do j = j1, n, 12
                  do i = 1, n
                     b( j   ) = b( j   ) + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                     b( j+8 ) = b( j+8 ) + a( i )
                     b( j+9 ) = b( j+9 ) + a( i )
                     b( j+10 ) = b( j+10 ) + a( i )
                     b( j+11 ) = b( j+11 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.13 ) then
            Do i11 = 1, m
               do j = j1, n, 13
                  do i = 1, n
                     b( j   ) = b( j   ) + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                     b( j+8 ) = b( j+8 ) + a( i )
                     b( j+9 ) = b( j+9 ) + a( i )
                     b( j+10 ) = b( j+10 ) + a( i )
                     b( j+11 ) = b( j+11 ) + a( i )
                     b( j+12 ) = b( j+12 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.14 ) then
            Do i11 = 1, m
               do j = j1, n, 14
                  do i = 1, n
                     b( j   ) = b( j   ) + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                     b( j+8 ) = b( j+8 ) + a( i )
                     b( j+9 ) = b( j+9 ) + a( i )
                     b( j+10 ) = b( j+10 ) + a( i )
                     b( j+11 ) = b( j+11 ) + a( i )
                     b( j+12 ) = b( j+12 ) + a( i )
                     b( j+13 ) = b( j+13 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.15 ) then
            Do i11 = 1, m
               do j = j1, n, 15
                  do i = 1, n
                     b( j   ) = b( j   ) + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                     b( j+8 ) = b( j+8 ) + a( i )
                     b( j+9 ) = b( j+9 ) + a( i )
                     b( j+10 ) = b( j+10 ) + a( i )
                     b( j+11 ) = b( j+11 ) + a( i )
                     b( j+12 ) = b( j+12 ) + a( i )
                     b( j+13 ) = b( j+13 ) + a( i )
                     b( j+14 ) = b( j+14 ) + a( i )
                  end do
               end do
            enddo
         elseif ( unroll.eq.16 ) then
            Do i11 = 1, m
               do j = j1, n, 16
                  do i = 1, n
                     b( j   ) = b( j   ) + a( i )
                     b( j+1 ) = b( j+1 ) + a( i )
                     b( j+2 ) = b( j+2 ) + a( i )
                     b( j+3 ) = b( j+3 ) + a( i )
                     b( j+4 ) = b( j+4 ) + a( i )
                     b( j+5 ) = b( j+5 ) + a( i )
                     b( j+6 ) = b( j+6 ) + a( i )
                     b( j+7 ) = b( j+7 ) + a( i )
                     b( j+8 ) = b( j+8 ) + a( i )
                     b( j+9 ) = b( j+9 ) + a( i )
                     b( j+10 ) = b( j+10 ) + a( i )
                     b( j+11 ) = b( j+11 ) + a( i )
                     b( j+12 ) = b( j+12 ) + a( i )
                     b( j+13 ) = b( j+13 ) + a( i )
                     b( j+14 ) = b( j+14 ) + a( i )
                     b( j+15 ) = b( j+15 ) + a( i )
                  end do
               end do
            enddo
         endif
      endif
C
      end


program template
  use arrayfire
  implicit none

  type(array) A1, A2, tmp
  integer :: I1(2), I2(2)

  ! 1D indexing
  A1 = randu(5, 1)
  A2 = constant(0, 5, 1)
  tmp = get(A1, [3,5])     ! Get elements 3 through 5
  call set(A2, tmp, [1,3]) ! Set elements 1 through 3 with values from tmp
  call print(A1,"A1")
  call print(tmp, "tmp")
  call print(A2,"A2")

  ! 2D indexing
  A1 = randu(3,3)
  A2 = constant(1,3,3)
  I1 = [1, 3]
  I2 = [2, 3]
  tmp = get(A1, idx(I1),  idx(I2))    ! Get rows 1 and 3 for columns 2 and 3
  call set(A2, tmp, idx(I2), idx(I1)) ! Set rows 2 and 3 for columns 1 and 3 with values from tmp
  call print(A1, "A1")
  call print(tmp, "tmp")
  call print(A2, "A2")

  ! 3D indexing
  A1 = randu(3,3,2)
  A2 = constant(1,3,3,2)
  I1 = [1, 3]
  I2 = [2, 3]
  tmp = get(A1, idx(I1),  [1,3,2], [1])  ! Get rows 1 and 3 for columns 1 and 3, tile 1
  call set(A2, tmp, idx(I2), [1,2], [2]) ! Set rows 2 and 3 for columns 1 and 2, tile 2 with tmp
  call print(A1, "A1")
  call print(tmp, "tmp")
  call print(A2, "A2")

end program template


! { dg-do compile }
! { dg-additional-options "-ffrontend-optimize -fdump-tree-original" }
! PR 82567 - long compile times caused by large constant constructors
! multiplied by variables

  SUBROUTINE sub()
  IMPLICIT NONE

  INTEGER, PARAMETER :: n = 1000
  REAL, ALLOCATABLE :: x(:)
  REAL :: xc, h
  INTEGER :: i

  ALLOCATE( x(n) )
  xc = 100.
  h = xc/n
  x = h*[(i,i=1,n)]

end
! { dg-final { scan-tree-dump-times "__var" 0 "original" } }


      INTEGER FUNCTION NPREROC( N, NB, IPROC, ISRCPROC, NPROCS )
*
*  -- ScaLAPACK tools routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER              IPROC, ISRCPROC, N, NB, NPROCS
*     ..
*
*  Purpose
*  =======
*
*  NPREROC computes the Number of PREceeding Rows Or Columns of a
*  distributed matrix that are possessed by processes closer to
*  ISRCPROC than IPROC.  Therefore, if ISRCPROC=0 and IPROC=4, then
*  NPREROC returns the number of distributed matrix rows or columns
*  owned by processes 0, 1, 2, and 3.
*
*  Arguments
*  =========
*
*  N         (global input) INTEGER
*            The number of rows or columns in the distributed matrix.
*
*  NB        (global input) INTEGER
*            Block size, size of the blocks the distributed matrix is
*            split into.
*
*  IPROC     (local intput) INTEGER
*            The coordinate of the process whose preceeding distributed
*            matrix rows or columns are to be determined.
*
*  ISRCPROC  (global input) INTEGER
*            The coordinate of the process that possesses the first
*            row or column of the distributed matrix.
*
*  NPROCS    (global input) INTEGER
*            The total number processes over which the matrix is
*            distributed.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER              EXTRABLKS, MYDIST, NBLOCKS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC            MOD
*     ..
*     .. Executable Statements ..
*
*     Figure PROC's distance from source process
*
      MYDIST = MOD( NPROCS+IPROC-ISRCPROC, NPROCS )
*
*     Figure the total number of whole NB blocks N is split up into
*
      NBLOCKS = N / NB
*
*     Figure the minimum number of rows/cols previous processes could have
*
      NPREROC = (NBLOCKS/NPROCS) * NB * MYDIST
*
*     See if there are any extra blocks
*
      EXTRABLKS = MOD( NBLOCKS, NPROCS )
*
*     If I have an extra block, all processes in front of me got one too
*
      IF( MYDIST.LE.EXTRABLKS ) THEN
         NPREROC = NPREROC + NB*MYDIST
*
*     If I have don't have an extra block, add in extra blocks of
*     preceeding processes and the partial block, if it exists
*
      ELSE
         NPREROC = NPREROC + EXTRABLKS*NB + MOD( N, NB )
      END IF
*
      RETURN
*
*     End of NPREROC
*
      END


program boj1259
  implicit none
  integer :: n
  do
    read*, n
    if (n .eq. 0) then
      exit
    end if
    if (is_palindrome(n)) then
      print '(A)', 'yes'
    else
      print '(A)', 'no'
    end if
  end do

  contains
  logical function is_palindrome(i)
    integer :: arr(100), last, i
    logical :: ok
    last = -1
    ok = .true.
    do while (i > 0)
      arr(last + 1) = mod(i, 10)
      i = i / 10
      last = last + 1
    end do
    do i = 0, last / 2
      ok = ok .and. (arr(i) == arr(last - i))
    end do
    is_palindrome = ok
  end function is_palindrome
end program boj1259