module electrostatic_pic_module

  use iso_c_binding
  use amrex_fort_module, only : amrex_real

  implicit none

contains

  subroutine sum_fine_to_crse_nodal (lo, hi, lrat, crse, clo, chi, fine, flo, fhi) &
       bind(c, name="sum_fine_to_crse_nodal")

    integer, intent(in)             ::   lo(2),  hi(2)
    integer, intent(in)             ::  clo(2), chi(2)
    integer, intent(in)             ::  flo(2), fhi(2)
    integer, intent(in)             ::  lrat(2)
    real(amrex_real), intent(inout) :: crse(clo(1):chi(1),clo(2):chi(2))
    real(amrex_real), intent(in)    :: fine(flo(1):fhi(1),flo(2):fhi(2))

    integer :: i, j, ii, jj

    do j     = lo(2), hi(2)
       jj    = j * lrat(2)
       do i  = lo(1), hi(1)
          ii = i * lrat(1)
          crse(i,j)  =  fine(ii,jj)                             + &
! These four fine nodes are shared by two coarse nodes...
               0.5d0   * (fine(ii-1,jj)     + fine(ii+1,jj)     + &
               fine(ii,jj-1)     + fine(ii,jj+1))               + &
! ... and these four are shared by four...
               0.25d0  * (fine(ii-1,jj-1)   + fine(ii-1,jj+1)   + &
               fine(ii-1,jj+1)   + fine(ii+1,jj+1))
! ... note that we have 9 nodes in total...
             crse(i,j) = crse(i,j) / 4.d0
       end do
    end do

  end subroutine sum_fine_to_crse_nodal

  subroutine zero_out_bndry (lo, hi, input_data, bndry_data, mask) &
       bind(c,name='zero_out_bndry')

    integer(c_int),   intent(in   ) :: lo(2), hi(2)
    double precision, intent(inout) :: input_data(lo(1):hi(1),lo(2):hi(2))
    double precision, intent(inout) :: bndry_data(lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1)
    integer(c_int),   intent(in   ) :: mask (lo(1):hi(1),lo(2):hi(2))

    integer :: i, j

    do j = lo(2), hi(2)
       do i = lo(1), hi(1)
          if (mask(i,j) .eq. 1) then
             bndry_data(i,j) = input_data(i,j)
             input_data(i,j) = 0.d0
          end if
       end do
    end do

  end subroutine zero_out_bndry

  subroutine build_mask (lo, hi, tmp_mask, mask, ncells) &
       bind(c,name='build_mask')
    integer(c_int),   intent(in   ) :: lo(2), hi(2)
    integer(c_int),   intent(in   ) :: ncells
    integer(c_int),   intent(in   ) :: tmp_mask(lo(1)-ncells:hi(1)+ncells,lo(2)-ncells:hi(2)+ncells)
    integer(c_int),   intent(inout) :: mask (lo(1):hi(1),lo(2):hi(2))

    integer :: i, j, ii, jj, total

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

          total = 0
          do ii = i-ncells, i+ncells
             do jj = j-ncells, j+ncells
                total = total + tmp_mask(ii, jj)
             end do
          end do

          if (total .gt. 0) then
             mask(i,j) = 1
          else
             mask(i,j) = 0
          end if

       end do
    end do

  end subroutine build_mask

! This routine computes the node-centered electric field given a node-centered phi.
! The gradient is computed using 2nd-order centered differences. It assumes the
! Boundary conditions have already been set and that you have one row of ghost cells.
! Note that this routine includes the minus sign in E = - grad phi.
!
! Arguments:
!     lo, hi:     The corners of the valid box over which the gradient is taken
!     Ex, Ey:     The electric field in the x and y directions.
!     dx:         The cell spacing
!
  subroutine compute_E_nodal (lo, hi, phi, Ex, Ey, dx) &
       bind(c,name='compute_E_nodal')
    integer(c_int),   intent(in)    :: lo(2), hi(2)
    real(amrex_real), intent(in)    :: dx(2)
    real(amrex_real), intent(in   ) :: phi(lo(1)-2:hi(1)+2,lo(2)-2:hi(2)+2)
    real(amrex_real), intent(inout) :: Ex (lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1)
    real(amrex_real), intent(inout) :: Ey (lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1)

    integer :: i, j
    real(amrex_real) :: fac(2)

    fac = 0.5d0 / dx

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

          Ex(i,j) = fac(1) * (phi(i-1,j) - phi(i+1,j))
          Ey(i,j) = fac(2) * (phi(i,j-1) - phi(i,j+1))

       end do
    end do

  end subroutine compute_E_nodal

! This routine computes the charge density due to the particles using cloud-in-cell
! deposition. The Fab rho is assumed to be node-centered.
!
! Arguments:
!     particles : a pointer to the particle array-of-structs
!     ns        : the stride length of particle struct (the size of the struct in number of reals)
!     np        : the number of particles
!     weights   : the particle weights
!     charge    : the charge of this particle species
!     rho       : a Fab that will contain the charge density on exit
!     lo        : a pointer to the lo corner of this valid box for rho, in index space
!     hi        : a pointer to the hi corner of this valid box for rho, in index space
!     plo       : the real position of the left-hand corner of the problem domain
!     dx        : the mesh spacing
!     ng        : the number of ghost cells in rho
!
  subroutine deposit_cic(particles, ns, np,                     &
                         weights, charge, rho, lo, hi, plo, dx, &
                         ng)                                    &
       bind(c,name='deposit_cic')
    integer, value,   intent(in)     :: ns, np
    real(amrex_real), intent(in)     :: particles(ns,np)
    real(amrex_real), intent(in)     :: weights(np)
    real(amrex_real), intent(in)     :: charge
    integer,          intent(in)     :: lo(2)
    integer,          intent(in)     :: hi(2)
    integer,          intent(in)     :: ng
    real(amrex_real), intent(inout)  :: rho(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng)
    real(amrex_real), intent(in)     :: plo(2)
    real(amrex_real), intent(in)     :: dx(2)

    integer i, j, n
    real(amrex_real) wx_lo, wy_lo, wx_hi, wy_hi
    real(amrex_real) lx, ly
    real(amrex_real) inv_dx(2)
    real(amrex_real) qp, inv_vol

    inv_dx = 1.0d0/dx

    inv_vol = inv_dx(1) * inv_dx(2)

    do n = 1, np

       qp = weights(n) * charge * inv_vol

       lx = (particles(1, n) - plo(1))*inv_dx(1)
       ly = (particles(2, n) - plo(2))*inv_dx(2)

       i = floor(lx)
       j = floor(ly)

       wx_hi = lx - i
       wy_hi = ly - j

       wx_lo = 1.0d0 - wx_hi
       wy_lo = 1.0d0 - wy_hi

       rho(i,   j  ) = rho(i,   j  ) + wx_lo*wy_lo*qp
       rho(i,   j+1) = rho(i,   j+1) + wx_lo*wy_hi*qp
       rho(i+1, j  ) = rho(i+1, j  ) + wx_hi*wy_lo*qp
       rho(i+1, j+1) = rho(i+1, j+1) + wx_hi*wy_hi*qp

    end do

  end subroutine deposit_cic

! This routine interpolates the electric field to the particle positions
! using cloud-in-cell interpolation. The electric fields are assumed to be
! node-centered.
!
! Arguments:
!     particles : a pointer to the particle array-of-structs
!     ns        : the stride length of particle struct (the size of the struct in number of reals)
!     np        : the number of particles
!     Ex_p      : the electric field in the x-direction at the particle positions (output)
!     Ey_p      : the electric field in the y-direction at the particle positions (output)
!     Ez_p      : the electric field in the z-direction at the particle positions (output)
!     Ex, Ey, Ez: Fabs conting the electric field on the mesh
!     lo        : a pointer to the lo corner of this valid box, in index space
!     hi        : a pointer to the hi corner of this valid box, in index space
!     plo       : the real position of the left-hand corner of the problem domain
!     dx        : the mesh spacing
!     ng        : the number of ghost cells for the E-field
!
  subroutine interpolate_cic(particles, ns, np,      &
                             Ex_p, Ey_p,             &
                             Ex,   Ey,               &
                             lo, hi, plo, dx, ng)    &
       bind(c,name='interpolate_cic')
    integer, value,   intent(in)     :: ns, np
    real(amrex_real), intent(in)     :: particles(ns,np)
    real(amrex_real), intent(inout)  :: Ex_p(np), Ey_p(np)
    integer,          intent(in)     :: ng
    integer,          intent(in)     :: lo(2)
    integer,          intent(in)     :: hi(2)
    real(amrex_real), intent(in)     :: Ex(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng)
    real(amrex_real), intent(in)     :: Ey(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng)
    real(amrex_real), intent(in)     :: plo(2)
    real(amrex_real), intent(in)     :: dx(2)

    integer i, j, n
    real(amrex_real) wx_lo, wy_lo, wx_hi, wy_hi
    real(amrex_real) lx, ly
    real(amrex_real) inv_dx(2)
    inv_dx = 1.0d0/dx

    do n = 1, np
       lx = (particles(1, n) - plo(1))*inv_dx(1)
       ly = (particles(2, n) - plo(2))*inv_dx(2)

       i = floor(lx)
       j = floor(ly)

       wx_hi = lx - i
       wy_hi = ly - j

       wx_lo = 1.0d0 - wx_hi
       wy_lo = 1.0d0 - wy_hi

       Ex_p(n) = wx_lo*wy_lo*Ex(i,   j  ) + &
                 wx_lo*wy_hi*Ex(i,   j+1) + &
                 wx_hi*wy_lo*Ex(i+1, j  ) + &
                 wx_hi*wy_hi*Ex(i+1, j+1)

       Ey_p(n) = wx_lo*wy_lo*Ey(i,   j  ) + &
                 wx_lo*wy_hi*Ey(i,   j+1) + &
                 wx_hi*wy_lo*Ey(i+1, j  ) + &
                 wx_hi*wy_hi*Ey(i+1, j+1)

    end do

  end subroutine interpolate_cic

  subroutine interpolate_cic_two_levels(particles, ns, np,      &
                                        Ex_p, Ey_p,             &
                                        Ex,   Ey,               &
                                        lo,   hi,   dx,         &
                                        cEx,  cEy,              &
                                        mask,                   &
                                        clo,  chi,  cdx,        &
                                        plo,  ng,   lev)        &
       bind(c,name='interpolate_cic_two_levels')
    integer, value,   intent(in)     :: ns, np
    real(amrex_real), intent(in)     :: particles(ns,np)
    real(amrex_real), intent(inout)  :: Ex_p(np), Ey_p(np)
    integer,          intent(in)     :: ng, lev
    integer,          intent(in)     :: lo(2), hi(2)
    integer,          intent(in)     :: clo(2), chi(2)
    real(amrex_real), intent(in)     :: Ex(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng)
    real(amrex_real), intent(in)     :: Ey(lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng)
    real(amrex_real), intent(in)     :: cEx(clo(1)-ng:chi(1)+ng, clo(2)-ng:chi(2)+ng)
    real(amrex_real), intent(in)     :: cEy(clo(1)-ng:chi(1)+ng, clo(2)-ng:chi(2)+ng)
    integer(c_int),   intent(in)     :: mask (lo(1):hi(1),lo(2):hi(2))
    real(amrex_real), intent(in)     :: plo(2)
    real(amrex_real), intent(in)     :: dx(2), cdx(2)

    integer i, j, n
    real(amrex_real) wx_lo, wy_lo, wx_hi, wy_hi
    real(amrex_real) lx, ly
    real(amrex_real) inv_dx(2), inv_cdx(2)
    inv_dx  = 1.0d0/dx
    inv_cdx = 1.0d0/cdx

    do n = 1, np

       lx = (particles(1, n) - plo(1))*inv_dx(1)
       ly = (particles(2, n) - plo(2))*inv_dx(2)

       i = floor(lx)
       j = floor(ly)

! use the coarse E if near the level boundary
       if (lev .eq. 1 .and. mask(i,j) .eq. 1) then

          lx = (particles(1, n) - plo(1))*inv_cdx(1)
          ly = (particles(2, n) - plo(2))*inv_cdx(2)

          i = floor(lx)
          j = floor(ly)

          wx_hi = lx - i
          wy_hi = ly - j

          wx_lo = 1.0d0 - wx_hi
          wy_lo = 1.0d0 - wy_hi

          Ex_p(n) = wx_lo*wy_lo*cEx(i,   j  ) + &
                    wx_lo*wy_hi*cEx(i,   j+1) + &
                    wx_hi*wy_lo*cEx(i+1, j  ) + &
                    wx_hi*wy_hi*cEx(i+1, j+1)

          Ey_p(n) = wx_lo*wy_lo*cEy(i,   j  ) + &
                    wx_lo*wy_hi*cEy(i,   j+1) + &
                    wx_hi*wy_lo*cEy(i+1, j  ) + &
                    wx_hi*wy_hi*cEy(i+1, j+1)

! otherwise use the fine
       else

          wx_hi = lx - i
          wy_hi = ly - j

          wx_lo = 1.0d0 - wx_hi
          wy_lo = 1.0d0 - wy_hi

          Ex_p(n) = wx_lo*wy_lo*Ex(i,   j  ) + &
                    wx_lo*wy_hi*Ex(i,   j+1) + &
                    wx_hi*wy_lo*Ex(i+1, j  ) + &
                    wx_hi*wy_hi*Ex(i+1, j+1)

          Ey_p(n) = wx_lo*wy_lo*Ey(i,   j  ) + &
                    wx_lo*wy_hi*Ey(i,   j+1) + &
                    wx_hi*wy_lo*Ey(i+1, j  ) + &
                    wx_hi*wy_hi*Ey(i+1, j+1)

       end if

    end do

  end subroutine interpolate_cic_two_levels

!
! This routine updates the particle positions and velocities using the
! leapfrog time integration algorithm, given the electric fields at the
! particle positions. It also enforces specular reflection off the domain
! walls.
!
! Arguments:
!     particles : a pointer to the particle array-of-structs
!     ns        : the stride length of particle struct (the size of the struct in number of reals)
!     np        : the number of particles
!     vx_p      : the particle x-velocities
!     vy_p      : the particle y-velocities
!     vz_p      : the particle z-velocities
!     Ex_p      : the electric field in the x-direction at the particle positions
!     Ey_p      : the electric field in the y-direction at the particle positions
!     Ez_p      : the electric field in the z-direction at the particle positions
!     charge    : the charge of this particle species
!     mass      : the mass of this particle species
!     dt        : the time step
!     prob_lo   : the left-hand corner of the problem domain
!     prob_hi   : the right-hand corner of the problem domain
!
  subroutine push_leapfrog(particles, ns, np,      &
                           vx_p, vy_p,             &
                           Ex_p, Ey_p,             &
                           charge, mass, dt,       &
                           prob_lo, prob_hi)       &
       bind(c,name='push_leapfrog')
    integer, value,   intent(in)     :: ns, np
    real(amrex_real), intent(inout)  :: particles(ns,np)
    real(amrex_real), intent(inout)  :: vx_p(np), vy_p(np)
    real(amrex_real), intent(in)     :: Ex_p(np), Ey_p(np)
    real(amrex_real), intent(in)     :: charge
    real(amrex_real), intent(in)     :: mass
    real(amrex_real), intent(in)     :: dt
    real(amrex_real), intent(in)     :: prob_lo(2), prob_hi(2)

    integer n
    real(amrex_real) fac

    fac = charge * dt / mass

    do n = 1, np

       vx_p(n) = vx_p(n) + fac * Ex_p(n)
       vy_p(n) = vy_p(n) + fac * Ey_p(n)

       particles(1, n) = particles(1, n) + dt * vx_p(n)
       particles(2, n) = particles(2, n) + dt * vy_p(n)

!      bounce off the walls in the x...
       do while (particles(1, n) .lt. prob_lo(1) .or. particles(1, n) .gt. prob_hi(1))
          if (particles(1, n) .lt. prob_lo(1)) then
             particles(1, n) = 2.d0*prob_lo(1) - particles(1, n)
          else
             particles(1, n) = 2.d0*prob_hi(1) - particles(1, n)
          end if
          vx_p(n) = -vx_p(n)
       end do

!      ... y...
       do while (particles(2, n) .lt. prob_lo(2) .or. particles(2, n) .gt. prob_hi(2))
          if (particles(2, n) .lt. prob_lo(2)) then
             particles(2, n) = 2.d0*prob_lo(2) - particles(2, n)
          else
             particles(2, n) = 2.d0*prob_hi(2) - particles(2, n)
          end if
          vy_p(n) = -vy_p(n)
       end do

    end do

  end subroutine push_leapfrog

!
! This routine advances the particle positions using the current
! velocity. This is needed to desynchronize the particle positions
! from the velocities after particle initialization.
!
! Arguments:
!     particles : a pointer to the particle array-of-structs
!     ns        : the stride length of particle struct (the size of the struct in number of reals)
!     np        : the number of particles
!     xx_p      : the electric field in the x-direction at the particle positions
!     vy_p      : the electric field in the y-direction at the particle positions
!     vz_p      : the electric field in the z-direction at the particle positions
!     dt        : the time step
!     prob_lo   : the left-hand corner of the problem domain
!     prob_hi   : the right-hand corner of the problem domain
!
  subroutine push_leapfrog_positions(particles, ns, np,      &
                                     vx_p, vy_p, dt,         &
                                     prob_lo, prob_hi)       &
       bind(c,name='push_leapfrog_positions')
    integer, value,   intent(in)    :: ns, np
    real(amrex_real), intent(inout) :: particles(ns,np)
    real(amrex_real), intent(inout) :: vx_p(np), vy_p(np)
    real(amrex_real), intent(in)    :: dt
    real(amrex_real), intent(in)    :: prob_lo(2), prob_hi(2)

    integer n

    do n = 1, np

       particles(1, n) = particles(1, n) + dt * vx_p(n)
       particles(2, n) = particles(2, n) + dt * vy_p(n)

!      bounce off the walls in the x...
       do while (particles(1, n) .lt. prob_lo(1) .or. particles(1, n) .gt. prob_hi(1))
          if (particles(1, n) .lt. prob_lo(1)) then
             particles(1, n) = 2.d0*prob_lo(1) - particles(1, n)
          else
             particles(1, n) = 2.d0*prob_hi(1) - particles(1, n)
          end if
          vx_p(n) = -vx_p(n)
       end do

!      ... y...
       do while (particles(2, n) .lt. prob_lo(2) .or. particles(2, n) .gt. prob_hi(2))
          if (particles(2, n) .lt. prob_lo(2)) then
             particles(2, n) = 2.d0*prob_lo(2) - particles(2, n)
          else
             particles(2, n) = 2.d0*prob_hi(2) - particles(2, n)
          end if
          vy_p(n) = -vy_p(n)
       end do

    end do

  end subroutine push_leapfrog_positions

end module electrostatic_pic_module


PROGRAM pg123
!-------------------------------------------------------------------------
!      program p12.3 three dimensional analysis of Laplace's equation
!      using 8-node bricks, DEC, preconditioned conjugate gradient solver
!      diagonal preconditioner; parallel; externally generated model
!-------------------------------------------------------------------------
!USE mpi_wrapper  !remove comment for serial compilation
 USE precision; USE global_variables; USE mp_interface; USE input
 USE output; USE loading; USE timing; USE maths; USE gather_scatter
 USE new_library; USE common_mod; USE geometry_mod; IMPLICIT NONE
!neq,ntot  are now global variables - not declared
 INTEGER, PARAMETER::ndim=3,nodof=1
 INTEGER::nod,nn,nr,nip,i,j,k,m,iters,limit,iel,partitioner,meshgen,     &
   node_end,node_start,nodes_pp,loaded_freedoms,fixed_freedoms,          &
   fixed_freedoms_pp,fixed_freedoms_start,nlen,nres,is,it,               &
   loaded_freedoms_pp,loaded_freedoms_start,nels,ndof,npes_pp,n_smplx,ne
 REAL(iwp),PARAMETER::zero=0.0_iwp,penalty=1.e20_iwp
 REAL(iwp)::kx,ky,kz,ka,det,tol,up,alpha,beta,q; CHARACTER(LEN=6)::ch
 CHARACTER(LEN=15)::element; CHARACTER(LEN=50)::argv
 LOGICAL::converged=.false.
 REAL(iwp),ALLOCATABLE::points(:,:),weights(:),eld_pp(:,:),kay(:),       &
   fun(:),jac(:,:),der(:,:),deriv(:,:),col(:,:),row(:,:),                &
   kcx(:,:),kcy(:,:),kcz(:,:),diag_precon_pp(:),p_pp(:),r_pp(:),x_pp(:), &
   xnew_pp(:),u_pp(:),pmul_pp(:,:),utemp_pp(:,:),d_pp(:),val(:,:),       &
   diag_precon_tmp(:,:),store_pp(:),storkc_pp(:,:,:),eld(:),timest(:),   &
   val_f(:),g_coord_pp(:,:,:),ptl_pp(:)
 INTEGER,ALLOCATABLE::rest(:,:),g_num_pp(:,:),g_g_pp(:,:),no(:),         &
   no_pp(:),no_f_pp(:),no_pp_temp(:),sense(:),node(:),smplx(:,:)
!--------------------------input and initialisation-----------------------
 ALLOCATE(timest(20)); timest=zero; timest(1)=elap_time()
 CALL find_pe_procs(numpe,npes); CALL getname(argv,nlen)
 CALL read_p123(argv,numpe,element,fixed_freedoms,kx,ky,kz,limit,        &
   loaded_freedoms,meshgen,nels,nip,nn,nod,nr,nres,partitioner,tol)
 CALL calc_nels_pp(argv,nels,npes,numpe,partitioner,nels_pp)
 ndof=nod*nodof; ntot=ndof
 ALLOCATE(g_num_pp(nod,nels_pp),g_coord_pp(nod,ndim,nels_pp))
 g_num_pp=0; g_coord_pp=zero
 CALL read_g_num_pp(argv,iel_start,nn,npes,numpe,g_num_pp)
 IF(meshgen == 2) CALL abaqus2sg(element,g_num_pp)
 CALL read_g_coord_pp(argv,g_num_pp,nn,npes,numpe,g_coord_pp)
 IF (nr>0) THEN; ALLOCATE(rest(nr,nodof+1)); rest=0
 CALL read_rest(argv,numpe,rest); END IF
 ALLOCATE (points(nip,ndim),jac(ndim,ndim),storkc_pp(ntot,ntot,nels_pp), &
   deriv(ndim,nod),kcx(ntot,ntot),weights(nip),der(ndim,nod),kay(ndim),  &
   pmul_pp(ntot,nels_pp),utemp_pp(ntot,nels_pp),col(ntot,1),eld(ntot),   &
   g_g_pp(ntot,nels_pp),kcy(ntot,ntot),row(1,ntot),kcz(ntot,ntot))
!----------  find the steering array and equations per process -----------
 timest(2)=elap_time(); g_g_pp=0; neq=0
 IF(nr>0) THEN; CALL rearrange_2(rest)
   elements_0: DO iel=1, nels_pp
     CALL find_g4(g_num_pp(:,iel),g_g_pp(:,iel),rest)
   END DO elements_0
 ELSE
   g_g_pp=g_num_pp  !When nr = 0, g_num_pp and g_g_pp are identical
 END IF
 neq=MAXVAL(g_g_pp); neq=max_p(neq); CALL calc_neq_pp
 CALL calc_npes_pp(npes,npes_pp); CALL make_ggl(npes_pp,npes,g_g_pp)
 DO i=1,neq_pp;IF(nres==ieq_start+i-1)THEN;it=numpe;is=i;END IF;END DO
 IF(numpe==it)THEN
   OPEN(11,FILE=argv(1:nlen)//'.res',STATUS='REPLACE',ACTION='WRITE')
   WRITE(11,'(A,I5,A)')"This job ran on ", npes,"  processes"
   WRITE(11,'(A,3(I7,A))')"There are ",nn," nodes",nr,                   &
     " restrained and   ",neq," equations"
   WRITE(11,'(A,F10.4)')"Time after setup is ",elap_time()-timest(1)
 END IF
 ALLOCATE(p_pp(neq_pp),r_pp(neq_pp),x_pp(neq_pp),xnew_pp(neq_pp),        &
   u_pp(neq_pp),diag_precon_pp(neq_pp),d_pp(neq_pp))
 r_pp=zero; p_pp=zero; x_pp=zero; xnew_pp=zero; diag_precon_pp=zero
!-------------- element stiffness using DEC and storage ----------------
 storkc_pp=zero;  dim_cmplx = 3;  dim_embbd = 3;  k=dim_cmplx+1
 ALLOCATE(num_pelm_pp(1)); num_pelm_pp(1)=nod;  extra_pelm=0;  glb_offset=0
 selectcase(element)
 case('hexahedron');   ne = 6;  glb_num_elm = (/ nod, 19, 18, ne /);
 case('tetrahedron');  ne = 1;  glb_num_elm = (/ nod, 19, 18, ne /);
 end SELECT
 num_elm=glb_num_elm;  ALLOCATE(lcl_complex(k));
 ALLOCATE(&
   lcl_complex(1)%centers(nod,dim_embbd),&
   lcl_complex(k)%orientation(ne),&
   lcl_complex(k)%node_indx(ne,k))
 lcl_complex(k)%orientation=0;  indx_offset = 0

 kay(1)=kx; kay(2)=ky; kay(3)=kz;
 elements_1: DO iel=1,nels_pp
   !- split elements into simplices
   CALL elm2smplx(num_elm(dim_cmplx+1),lcl_complex(dim_cmplx+1)%node_indx,&
      g_coord_pp(:,:,iel),element,nod)

   !- Recursively compute element (co-)boundaries
   DO k=dim_cmplx+1,2,-1;  CALL calc_bndry_cobndry(k);  END DO

   !- setup connectivity
   DO k=1,dim_cmplx+1
     lcl_complex(k)%lcl_node_indx = lcl_complex(k)%node_indx
   END DO

   !- calc circumcenter
   lcl_complex(1)%centers = g_coord_pp(:,:,iel)
   DO k=2,dim_cmplx+1; CALL calc_circumcenters(k); END DO

   !- calc primal edge and dual area
   CALL calc_prml_unsgnd_vlm(2); CALL calc_dual_vlm(2);  CALL calc_prml_dir()

   kcx=zero
   DO i=1,nod
     DO j=1,lcl_complex(1)%num_cobndry(i)
       k = lcl_complex(1)%cobndry(i)%indx(j)
       IF (ABS(lcl_complex(2)%dual_volume(k) / &
          max(lcl_complex(2)%prml_volume(k),small))<smalls) CYCLE
       m = lcl_complex(2)%bndry(k)%indx(1)
       IF (i==m) m = lcl_complex(2)%bndry(k)%indx(2)
       ka = DOT_PRODUCT(kay,abs(lcl_complex(2)%prml_dir(k,:)))
       kcx(i,m) = kcx(i,m) - ka*lcl_complex(2)%dual_volume(k) / &
          max(lcl_complex(2)%prml_volume(k),small)
       kcx(i,i) = kcx(i,i) + ka*lcl_complex(2)%dual_volume(k) / &
          max(lcl_complex(2)%prml_volume(k),small)
     END DO
   END DO;  storkc_pp(:,:,iel)=kcx

   !- Deallocate variables
   DO k=1,dim_cmplx+1;
     IF (ALLOCATED(lcl_complex(k)%recv_indx))   DEALLOCATE(lcl_complex(k)%recv_indx)
     IF (ALLOCATED(lcl_complex(k)%num_bndry))   DEALLOCATE(lcl_complex(k)%num_bndry)
     IF (ALLOCATED(lcl_complex(k)%bndry))       DEALLOCATE(lcl_complex(k)%bndry)
     IF (ALLOCATED(lcl_complex(k)%num_cobndry)) DEALLOCATE(lcl_complex(k)%num_cobndry)
     IF (ALLOCATED(lcl_complex(k)%cobndry))     DEALLOCATE(lcl_complex(k)%cobndry)
     IF (ALLOCATED(lcl_complex(k)%node_indx))   DEALLOCATE(lcl_complex(k)%node_indx)
   END DO
 END DO elements_1
!------------------ build the diagonal preconditioner --------------------
 ALLOCATE(diag_precon_tmp(ntot,nels_pp)); diag_precon_tmp=zero
 elements_1a: DO iel=1,nels_pp
   DO i=1,ndof
     diag_precon_tmp(i,iel)=diag_precon_tmp(i,iel)+storkc_pp(i,i,iel)
   END DO
 END DO elements_1a; CALL scatter(diag_precon_pp,diag_precon_tmp)
 DEALLOCATE(diag_precon_tmp)
!------------- read in fixed freedoms and assign to equations ------------
 IF(fixed_freedoms>0) THEN
   ALLOCATE(node(fixed_freedoms),no_pp_temp(fixed_freedoms),             &
     val_f(fixed_freedoms),no(fixed_freedoms),sense(fixed_freedoms))
   node=0; no=0; no_pp_temp=0; sense=0; val_f=zero
   CALL read_fixed(argv,numpe,node,sense,val_f)
   CALL find_no2(g_g_pp,g_num_pp,node,sense,no)
   CALL reindex(ieq_start,no,no_pp_temp,fixed_freedoms_pp,               &
     fixed_freedoms_start,neq_pp)
   ALLOCATE(no_f_pp(fixed_freedoms_pp),store_pp(fixed_freedoms_pp))
   no_f_pp=0; store_pp=zero; no_f_pp=no_pp_temp(1:fixed_freedoms_pp)
   DEALLOCATE(node,no,sense,no_pp_temp)
 END IF
 IF(fixed_freedoms==0) fixed_freedoms_pp=0; IF(nr>0) DEALLOCATE(rest)
!------------ read in loaded freedoms and get starting r_pp --------------
 IF(loaded_freedoms>0) THEN
   ALLOCATE(node(loaded_freedoms),val(nodof,loaded_freedoms),            &
     no_pp_temp(loaded_freedoms)); val=zero; node=0
   CALL read_loads(argv,numpe,node,val)
   CALL reindex(ieq_start,node,no_pp_temp,loaded_freedoms_pp,            &
     loaded_freedoms_start,neq_pp); ALLOCATE(no_pp(loaded_freedoms_pp))
   no_pp=no_pp_temp(1:loaded_freedoms_pp); DEALLOCATE(no_pp_temp)
   DO i = 1, loaded_freedoms_pp
     r_pp(no_pp(i)-ieq_start+1) = val(1,loaded_freedoms_start+i-1)
   END DO; q=SUM_P(r_pp); DEALLOCATE(node,val)
 END IF
!-------------------------- invert preconditioner ------------------------
 IF(fixed_freedoms_pp>0) THEN
   DO i=1,fixed_freedoms_pp; j=no_f_pp(i)-ieq_start+1
     diag_precon_pp(j)=diag_precon_pp(j)+penalty
     store_pp(i)=diag_precon_pp(j)
   END DO
 END IF;  diag_precon_pp = 1._iwp/diag_precon_pp
!---------------- initialise preconditioned conjugate gradient -----------
 IF(fixed_freedoms_pp>0) THEN
   DO i=1,fixed_freedoms_pp
     j=no_f_pp(i)-ieq_start+1; k=fixed_freedoms_start+i-1
     r_pp(j)=store_pp(i)*val_f(k)
   END DO
 END IF;  d_pp=diag_precon_pp*r_pp; p_pp=d_pp; x_pp=zero
!--------------- preconditioned conjugate gradient iterations ------------
 iters=0; timest(3)=elap_time()
 iterations: DO
   iters=iters+1; u_pp=zero; pmul_pp=zero; utemp_pp=zero
   CALL gather(p_pp,pmul_pp)
   elements_2 : DO iel = 1, nels_pp
     utemp_pp(:,iel) = MATMUL(storkc_pp(:,:,iel),pmul_pp(:,iel))
   END DO elements_2 ; CALL scatter(u_pp,utemp_pp)
   IF(fixed_freedoms_pp>0) THEN
     DO i=1,fixed_freedoms_pp
       j=no_f_pp(i)-ieq_start+1; u_pp(j)=p_pp(j)*store_pp(i)
     END DO
   END IF
   up=DOT_PRODUCT_P(r_pp,d_pp); alpha=up/DOT_PRODUCT_P(p_pp,u_pp)
   xnew_pp=x_pp+p_pp*alpha; r_pp=r_pp-u_pp*alpha
   d_pp=diag_precon_pp*r_pp; beta=DOT_PRODUCT_P(r_pp,d_pp)/up
   p_pp=d_pp+p_pp*beta; CALL checon_par(xnew_pp,tol,converged,x_pp)
   IF(converged .OR. iters==limit) EXIT
 END DO iterations
 timest(4)=elap_time()
 IF(numpe==it)THEN
   WRITE(11,'(A,I5)')"The number of iterations to convergence was ",iters
   WRITE(11,'(A,E12.4)')"The total load is ",q
   WRITE(11,'(A)')   "The potentials are:"
   WRITE(11,'(A)') " Freedom       Potential"
   DO i=1,4
     WRITE(11,'(I8,A,E12.4)') nres+i-1, "     ", xnew_pp(is+i-1)
   END DO
   WRITE(11,'(A,F10.4)')"Integration, preconditioning and loading took ",&
     timest(3)-timest(2)
   WRITE(11,'(A,F10.4)') "Time spent in the solver was ",                &
     timest(4)-timest(3)
 END IF
!------------------- output potentials for ParaView ----------------------
 IF(numpe==1)THEN; WRITE(ch,'(I6.6)') numpe
   OPEN(12,file=argv(1:nlen)//".ensi.NDPTL-"//ch,status='replace',       &
     action='write')
   WRITE(12,'(A)') "Alya Ensight Gold --- Scalar per-node variable file"
   WRITE(12,'(A/A/A)') "part", "    1","coordinates"
 END IF
 CALL calc_nodes_pp(nn,npes,numpe,node_end,node_start,nodes_pp)
 ALLOCATE(ptl_pp(nodes_pp*ndim))
 ptl_pp=zero; utemp_pp=zero; CALL gather(xnew_pp(1:),utemp_pp)
 CALL scatter_nodes(npes,nn,nels_pp,g_num_pp,nod,nodof,nodes_pp,         &
   node_start,node_end,utemp_pp,ptl_pp,1)
 CALL dismsh_ensi_p(12,1,nodes_pp,npes,numpe,1,ptl_pp)
 IF(numpe==it)                                                           &
   WRITE(11,'(A,F10.4)') "This analysis took ",elap_time()-timest(1)
 IF(numpe==it) CLOSE(11); IF(numpe==1) CLOSE(12); CALL SHUTDOWN()
END PROGRAM pg123


c
c reads in a data set with metallic eps.
c
      implicit real*8(a-h,o-z)
      complex*16 ri,refrel, epsc,t1(300), t2(300)
      character*60 sigdat,epsdat
      dimension ang(300)
      ri=(0.d0,1.d0)
      c=2.997925d8
      pi=4*datan(1.d0)
      rnm=1.d-9
c
c
c      refmed=1.5d0
       refmed=1.d0
c
c read in eps file and
c specify radius of cylinder in nm
c
      read(5,*)epsdat,nom
      read(5,*)rad
      rad=rad*1.e-9
c
c read output data file name
      read(5,*)sigdat
      open(unit=7,file=sigdat,status='unknown')
      open(unit=8,file=epsdat,status='old')
c
c
c loop over lambda or freqs :
c
      do 666 iom=1,nom
      read(8,*)rlamb,epsre,epsim
c
      epsc=epsre+ri*epsim
      refrel=cdsqrt(epsc)/refmed
c
      omega=2.d0*pi*c/(rlamb*rnm)
c
c
c
      wavel=2.d0*pi*c/omega
c
      x=2.d0*pi*rad*refmed/wavel
c
      fin=180.d0
c
c      intang=20
c skg change relative to Bohren and Huffman :
      intang=200
c
      call bhcyl(x,refrel,t1,t2,qscpar,qscper,qexpar,qexper,
     > fin,intang,ang)
c
c
c       write(6,*)' omega/10**15 ',omega/1.d15
c       write(6,*)' qscpar, qexpar ',qscpar,qexpar
c       write(6,*)' qscper, qexper ',qscper,qexper
c       write(6,*)' '
c
c write out E field perpendicular to cyl axis info
c 2*rad/1.e-9 converts to nm units
       qscout=qscpar*2*rad/1.d-9
       qexout= qexpar*2*rad/1.d-9
       qabout=  qexout - qscout
c
       write(7,1000)rlamb,qscout,qabout,qexout
c
 666   continue
c
 1000   format(1x,4e13.5)
c
        stop
        end
c
c
      subroutine bhcyl(x,refrel,t1,t2,qscpar,qscper,qexpar,qexper,
     > fin,intang,ang)
c
       implicit real*8(a-h,o-z)
       complex*16 refrel,y,an,bn,a0,b0
       complex*16 g(5000),bh(5000),t1(300),t2(300)
       dimension theta(300),ang(300),bj(5000),by(5000),f(5000)
c
      qcspar=0.d0
      qcsper=0.d0
      qexpar=0.d0
      qexper=0.d0
c
      radcon=4.d0*datan(1.d0)/180.d0
c
      y=x*refrel
c      xstop=x+4*x**(0.333333333333333d0) + 2.d0
c      nstop=xstop
c skg change -- include many more terms in iteration
      xstop=5*x
      nstop=xstop
c end of this skg change
c
      ymod=cdabs(y)
      nmx=dmax1(xstop,ymod)+15
      npts=intang+1
      dang=fin/dfloat(intang)
c
      do j=1,npts
      ang(j)=(dfloat(j)-1.d0)*dang
      theta(j)=ang(j)*radcon
      enddo
c
      g(nmx)=dcmplx(0.d0,0.d0)
      nn=nmx-1
c
      do n=1,nn
      rn=nmx-n+1
      k=nmx-n
      g(k)=( (rn-2.d0)/y ) - ( 1.d0/(g(k+1)+(rn-1.d0)/y) )
      enddo
c
c
      ndelta=(101.d0+x)**(0.499d0)
      mst=nstop+ndelta
c skg comment -- I guess this makes mst "even" :
      mst=(mst/2)*2
c
c top of p. 496 now :
c
      f(mst+1)=0.d0
      f(mst)=1.d-32
      m1=mst-1
c
      do l=1,m1
      ml=mst-l
      f(ml)=2*dfloat(ml) * f(ml+1)/x - f(ml+2)
      enddo
c
      alpha=f(1)
      m2=mst-2
c
      do ll=2,m2,2
      alpha=alpha+2*f(ll+1)
      enddo
c
      m3=m2+1
c
      do n=1,m3
      bj(n)=f(n)/alpha
      enddo
c
      by(1)=bj(1)*(dlog(x/2.d0)+0.577215664d0)
      m4=mst/2-1
c
      do l=1,m4
      by(1)=by(1)-2*((-1.d0)**l)*bj(2*l+1)/dfloat(l)
      enddo
c
      by(1)=0.636619772d0*by(1)
      by(2)=bj(2)*by(1)-0.636619772d0/x
      by(2)=by(2)/bj(1)
c
      ns=nstop-1
c
      do kk=1,ns
      by(kk+2)=2*dfloat(kk)*by(kk+1)/x-by(kk)
      enddo
c
      nn=nstop+1
c
      do n=1,nn
      bh(n)=dcmplx(bj(n),by(n))
      enddo
c
      a0=g(1)*bj(1)/refrel+bj(2)
      a0=a0/(g(1)*bh(1)/refrel+bh(2))
      b0=refrel*g(1)*bj(1)+bj(2)
      b0=b0/(refrel*g(1)*bh(1)+bh(2))
c
      qscpar=cdabs(b0)*cdabs(b0)
      qscper=cdabs(a0)*cdabs(a0)
c
      do k=1,npts
      t1(k)=b0
      t2(k)=a0
      enddo
c
      do n=1,nstop
      rn=n
      an=(g(n+1)/refrel+rn/x)*bj(n+1)-bj(n)
      an=an/((g(n+1)/refrel+rn/x)*bh(n+1)-bh(n))
      bn=(refrel*g(n+1)+rn/x)*bj(n+1)-bj(n)
      bn=bn/((refrel*g(n+1)+rn/x)*bh(n+1)-bh(n))
c
       do j=1,npts
       c=dcos(rn*theta(j))
       t1(j)=2*bn*c+t1(j)
       t2(j)=2*an*c+t2(j)
       enddo
c
      qscpar=qscpar+2*cdabs(bn)*cdabs(bn)
      qscper=qscper+2*cdabs(an)*cdabs(an)
c
      enddo
c
c
      qscpar=(2.d0/x)*qscpar
      qscper=(2.d0/x)*qscper
      qexper=(2.d0/x)*dreal(t2(1))
      qexpar=(2.d0/x)*dreal(t1(1))
c
c
c
      return
      end
c
      subroutine drude(omega,epsre,epsim,refre,refim)
      implicit real*8(a-h,o-z)
      complex*16 cc,ri
      ri=(0.d0,1.d0)
c
c Ag parameters, omp and gam in ev :
c      epsinf=7.342d0
c      omp=10.511d0
c      gam=0.0804d0
c D1 param
       epsinf=8.926
       omp=11.585
       gam=0.2030

c
c convert omega to ev :
c
      om=27.2114d0*omega*2.41888d-17
c
      opop=omp*omp
      omom=om*om
c
c the dielectric const :
c
      cc=epsinf - opop/(omom+ri*gam*om)
c
       epsre= dreal(cc)
       epsim= dimag(cc)
c
c now get refractive index :
c
       arg=dsqrt( epsre**2 + epsim**2)
c
       refre=dsqrt( (arg +epsre)/2.d0)
       refim=dsqrt( (arg -epsre)/2.d0)
c
c        write(6,*)' om/ev ',om
c        write(6,*)' diel ',epsre,epsim
c        write(6,*)' n,k  ',refre,refim
       return
      end


      subroutine ire_hs(ctfm,ctfmp,n_A,n_Athth,n_Axx,n_B,n_K,n_Lamx,n_ps
     &i,n_rho,octfmp,Nx,hx,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_Athth(Nx)
      real*8 n_Axx(Nx)
      real*8 n_B(Nx)
      real*8 n_K(Nx)
      real*8 n_Lamx(Nx)
      real*8 n_psi(Nx)
      real*8 n_rho(Nx)
      real*8 octfmp(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=5, Nx, 1
      qb = -0.8333333333333333D-1 * n_psi(i) ** 5 * n_K(i) ** 2 + 0.2500
     #000000000000D0 * n_rho(i) * n_psi(i) ** 5 + 0.1250000000000000D0 /
     # n_A(i) ** 2 * n_Axx(i) ** 2 * n_psi(i) ** 5 + 0.2500000000000000D
     #0 / n_B(i) ** 2 * n_Athth(i) ** 2 * n_psi(i) ** 5 + (-0.3125000000
     #000000D-1 / n_A(i) * n_Lamx(i) * (n_A(i - 2) - 0.4D1 * n_A(i - 1)
     #+ 0.3D1 * n_A(i)) / hx * n_psi(i) - 0.3125000000000000D-1 * (n_A(i
     # - 2) - 0.4D1 * n_A(i - 1) + 0.3D1 * n_A(i)) / hx / n_A(i) ** 2 *
     #n_psi(i) * octfmp(i) - 0.6250000000000000D-1 / n_B(i) * (n_B(i - 2
     #) - 0.4D1 * n_B(i - 1) + 0.3D1 * n_B(i)) / hx * n_Lamx(i) * n_psi(
     #i) - 0.6250000000000000D-1 * (n_B(i - 2) - 0.4D1 * n_B(i - 1) + 0.
     #3D1 * n_B(i)) / hx / n_B(i) / n_A(i) * n_psi(i) * octfmp(i) + 0.62
     #50000000000000D-1 * (-0.1D1 * n_Lamx(i - 2) + 0.4D1 * n_Lamx(i - 1
     #) - 0.3D1 * n_Lamx(i)) / hx * n_psi(i) - 0.5000000000000000D0 / n_
     #A(i) * (n_psi(i - 2) - 0.4D1 * n_psi(i - 1) + 0.3D1 * n_psi(i)) /
     #hx * octfmp(i)) / ctfmp(i) + (-0.2343750000000000D-1 / n_A(i) ** 3
     # * (n_A(i - 2) - 0.4D1 * n_A(i - 1) + 0.3D1 * n_A(i)) ** 2 / hx **
     # 2 * n_psi(i) - 0.1250000000000000D0 / n_A(i) ** 2 * (n_A(i - 2) -
     # 0.4D1 * n_A(i - 1) + 0.3D1 * n_A(i)) / hx ** 2 * (n_psi(i - 2) -
     #0.4D1 * n_psi(i - 1) + 0.3D1 * n_psi(i)) - 0.1562500000000000D-1 /
     # n_B(i) ** 2 / n_A(i) * (n_B(i - 2) - 0.4D1 * n_B(i - 1) + 0.3D1 *
     # n_B(i)) ** 2 / hx ** 2 * n_psi(i) + 0.2500000000000000D0 / n_B(i)
     # / n_A(i) * (n_B(i - 2) - 0.4D1 * n_B(i - 1) + 0.3D1 * n_B(i)) / h
     #x ** 2 * (n_psi(i - 2) - 0.4D1 * n_psi(i - 1) + 0.3D1 * n_psi(i))
     #+ 0.8333333333333333D-1 / n_A(i) * (0.11D2 * n_psi(i - 4) - 0.56D2
     # * n_psi(i - 3) + 0.114D3 * n_psi(i - 2) - 0.104D3 * n_psi(i - 1)
     #+ 0.35D2 * n_psi(i)) / hx ** 2 + 0.5208333333333333D-2 / n_A(i) **
     # 2 * (0.11D2 * n_A(i - 4) - 0.56D2 * n_A(i - 3) + 0.114D3 * n_A(i
     #- 2) - 0.104D3 * n_A(i - 1) + 0.35D2 * n_A(i)) / hx ** 2 * n_psi(i
     #) + 0.1041666666666667D-1 / n_B(i) / n_A(i) * n_psi(i) * (0.11D2 *
     # n_B(i - 4) - 0.56D2 * n_B(i - 3) + 0.114D3 * n_B(i - 2) - 0.104D3
     # * n_B(i - 1) + 0.35D2 * n_B(i)) / hx ** 2) / ctfmp(i) ** 2 + (-0.
     #2500000000000000D0 * n_Lamx(i) * n_psi(i) + (0.6250000000000000D-1
     # * (n_A(i - 2) - 0.4D1 * n_A(i - 1) + 0.3D1 * n_A(i)) / hx / n_B(i
     #) / n_A(i) * n_psi(i) + 0.1250000000000000D0 * (n_B(i - 2) - 0.4D1
     # * n_B(i - 1) + 0.3D1 * n_B(i)) / hx / n_B(i) / n_A(i) * n_psi(i)
     #+ 0.1D1 / n_A(i) * (n_psi(i - 2) - 0.4D1 * n_psi(i - 1) + 0.3D1 *
     #n_psi(i)) / hx) / ctfmp(i)) / ctfm(i)
      res(i)=qb
      end do
      END


           program demo_fraction
           implicit none
             real :: x
             x = 178.1387e-4
             print *, fraction(x), x * radix(x)**(-exponent(x))
           end program demo_fraction


! { dg-do compile }
!
! Check whether ERF/ERFC take scalars and arrays as arguments (PR31760).
!
PROGRAM test_erf
  REAL :: r = 0.0, ra(2) = (/ 0.0, 1.0 /)

  r  = erf(r)
  r  = erfc(r)

  ra = erf(ra)
  ra = erfc(ra)
END PROGRAM


!-------------------------------------------------------------------------
!Author: Matias Pablo, Borghi Orue
!Title: 2D Monte Carlo simulation of the Ising Model
!Version: 1
!Comments:  $ gfortran ranmar_seed.f95 subroutines.f95 ising.f95 -o runv1
!INPUTS: None
!OUTPUTS: Two dat files: 'Magnetization30L.dat' and 'Energy30L.dat'
!-------------------------------------------------------------------------
program ising

use subroutines
use rm
use iso_fortran_env
implicit none
	integer, parameter :: dp = selected_real_kind(15, 307)
	integer::ncols, average,iniseed
	integer::posx,posy,dim
	integer,allocatable::ip(:),im(:)
	integer:: MCS, EquilSteps
	integer:: i,j,k,indexTemp,printInfo !Dummy indeces
	integer::index1,index2
	real::Delta_E
	integer,allocatable::matriz(:,:)
	integer::promediateCounter = 0
	real::rvec(1)
	real(dp),allocatable::MagnetizationAver(:), MagnetizationAver2(:),MagnetizationAver4(:),EnergyAver(:),EnergyAver2(:)
	real,dimension(20)::DeltaE
	real,allocatable::alpha(:,:)
	real::alpha11,alpha33
	!Temp quantities
	real::beta
	!Field quantities
	real::currentField

	integer::fieldPoints,indexField
	character(len=10):: stringL
	character(len=100)::MagFile ='Magnetization.dat', EnergFile = 'Energy20L.dat'
	character(len=100):: folderName,FileOutput='OutputFile.log'

	real:: fieldValues1(1:40) = (/(i*0.002475, i=1,40,1) /),fieldValues2(1:40) = (/(i*0.002475+0.1,i=1,40,1) /)!,fieldValues3(-20:20) = (/(i*0.01,i=-20,20,1) /)
	real,allocatable::fieldValues(:)
	!real::fieldValues(1:30) = (/ (i*0.1,i=1,30,1) /)
	real:: currentTemp = 2.0,alpha13 = -1.0
	integer::nrows = 64

	!fieldPoints = size(fieldValues)

	! Read in input parameters from file "ising.in"
	open(unit=11,file="ConfigurationFile",status="old",action="read")
	read(11,*);read(11,*) printInfo
	read(11,*);read(11,*) iniseed
	read(11,*);read(11,*) MCS
	read(11,*);read(11,*) EquilSteps
	read(11,*);read(11,*) average
	read(11,*);read(11,*) alpha11
	read(11,*);read(11,*) alpha33
	close(11)

	!Fill the field values
	fieldPoints = size(fieldValues1) + size(fieldValues2) !+ size(fieldValues3)
	allocate(fieldValues(fieldPoints))
	fieldValues(1:size(fieldValues1)) = fieldValues1
	fieldValues(size(fieldValues1)+1:size(fieldValues1)+size(fieldValues2)) = fieldValues2
	!fieldValues(size(fieldValues1)+size(fieldValues2)+1:size(fieldValues)) = fieldValues3
	!print *, fieldValues
	!call EXIT(0)
	!-----------------
	ncols = nrows
	! Set the dimensions of the matrix of spin arrays. This program uses
	! periodic boundary conditions, so the first two rows and columns are
	! the same as the last two.
	allocate(matriz(nrows,ncols))
	allocate(alpha(3,3))

	allocate(MagnetizationAver(fieldPoints))
	allocate(MagnetizationAver2(fieldPoints))
	allocate(MagnetizationAver4(fieldPoints))
	allocate(EnergyAver(fieldPoints))
	allocate(EnergyAver2(fieldPoints))

	!Change this to take in count that the matrix can be rectangular
	allocate(im(nrows))
	allocate(ip(nrows))

	do i = 1,nrows
		ip(i) = i+1
		im(i) = i-1
	end do
	ip(nrows) = 1
	im(1) = nrows

	dim = nrows*ncols
	!MCS = 20000!dim*10
	!EquilSteps = 10000!int (0.5*MCS)

	write(stringL,'(I3.3)') nrows
	folderName = 'L='//trim(stringL)

	open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),status="replace",action="write")
	write(2,*) 'Parameters in this simulation'
	write(2,*) 'L=',nrows
	write(2,*) 'Temp=',currentTemp
	write(2,*) 'Number of B points =', size(fieldValues)
	write(2,*) 'Alpha=',alpha11,' ',alpha13,' ',alpha33
	write(2,*) 'MCS=',MCS
	write(2,*) 'aver=',average

	if ( EquilSteps >= MCS ) then
		write(2,*) 'Error! Change the value of EquilSteps in the Configuration File! It can not be greater than MCS'
		call EXIT(0)
	end if

	write(2,*) 'Semilla RANMAR: ',iniseed
	write(2,*) "MCS = ",MCS, " EquilSteps = ", EquilSteps

	!If the file exists overwrite erase it.
	!open (UNIT=1, FILE=trim(folderName)//'/'//trim(MagFile),ACTION='write',STATUS='replace')
	!write(1,*) "Temp,B-Field, AverMagnetization, AverMagnetization^2, Suceptibility, Cumulant"
	!open (UNIT=33, FILE=trim(folderName)//'/'//trim(EnergFile),ACTION='write',STATUS='replace')
	!write(33,*) "Temp,B-Field, AverEnergy, AverEnergy^2, C_v"

	call ini_alpha(alpha,alpha11,alpha13,alpha33)
	!Initialize the matrix
	!with spin-up initial values
	call ini_matriz(matriz,nrows,ncols)
	close(2)

	if (printInfo /= 0) then
		call WriteSpinConf(matriz,nrows,ncols)
	end if

	!Initialize some variables to zero
	call SetToZeroVariables(MagnetizationAver,MagnetizationAver2,MagnetizationAver4,EnergyAver,EnergyAver2,fieldPoints)
	!call WriteSpinConf(matriz,nrows,ncols)
	beta = 1.0/currentTemp
	!Define the values of DeltaE knowing the Temperature
	!Only two possible values
	! 1) DeltaE(1) = exp(-4/Temp)
	! 2) DeltaE(2) = exp(-8/Temp)
	call Inicializacion_DeltaE(DeltaE,currentTemp)

	do k = 1 , average
		open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),access="append",action="write")
		write(2,*) 'k = ',k,'/',average
		close(2)

		do indexField = 1,fieldPoints !Loop over all the temperatures from Tmax to Tmin
			promediateCounter = 0
			!Change the temperature value
			currentField = fieldValues(indexField)
			open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),access="append",action="write")
			write(2,*), "Current Field B = ", currentField
			close(2)

			!Choose a random point (posx,posy) where we begin calculating
			call elegir_sitio(nrows,ncols,posx,posy,iniseed,k)

			!Sum over one MonteCarlo time //dim = 1MC
			!Sum over A MonteCarlo time: A*dim
			!In the next loop we flip a sping according to some conditions
			do i=1,MCS

				do j = 1,dim

					!Calculate DeltaE for a given point (posx,posy)
					call CalcDeltaEnergy(nrows,ncols,posx,posy,matriz,Delta_E,ip,im,alpha,currentField)

					!call ranmar(rvec,iniseed*verage)
					! ..Flipping Spin..
					!If the new Energy spin-state is negative with flip the spin
					!If not it will depend on the probability exp(-DeltaE/Temp) > random point
					if (Delta_E <= 0) then
						matriz(posx,posy) = - matriz(posx,posy)
					else
						call ranmar(rvec,1,iniseed*k)
						if (Delta_E == int(Delta_E) .AND. Delta_E<=20) then
							if (rvec(1) < DeltaE(int(Delta_E))) then
									matriz(posx,posy) = -matriz(posx,posy)
							end if
						else
							if ( rvec(1) < exp(-Delta_E/currentTemp) ) then
								matriz(posx,posy) = -matriz(posx,posy)
							end if
						end if

					end if

					!Choose a new random point (posx,posy) where we begin calculating
					call elegir_sitio(nrows,ncols,posx,posy,iniseed,k)

					!----------------------------------------------------------------
					!-----PRINTF IN DYNAMIC LATTICE ---------------------------------
					if (printInfo == 1) then
						call WriteSpinConf(matriz,nrows,ncols)
					end if
					!-----------------------------------------------------------------

				end do !End j loop

				!Calculate the Magnetization and Energy after equilibrium
				if (i > EquilSteps ) then
					promediateCounter = promediateCounter + 1
					call CalculationsINequilibrium (nrows,ncols,matriz,Delta_E,EnergyAver(indexField),EnergyAver2(indexField), &
										MagnetizationAver(indexField),MagnetizationAver2(indexField),MagnetizationAver4(indexField),ip,im,alpha,currentField)

					if (printInfo == 2) then
						call WriteSpinConf(matriz,nrows,ncols)
					else if (printInfo == 3 .AND. mod(i,MCS/10) == 0 .AND. k==1) then
						call WriteSpinConf(matriz,nrows,ncols)
					end if

				end if

			end do !End loop of the MC steps
			!call WriteSpinConf(matriz,nrows,ncols)
		end do ! End loop of Temperatures
	end do !End loop of averages
	!Write the results in a file
	call Write2File(promediateCounter, MagnetizationAver,MagnetizationAver2,MagnetizationAver4,EnergyAver,EnergyAver2,fieldValues,fieldPoints,average,currentTemp,folderName,MagFile)

	open(unit=2,file=trim(folderName)//'/'//trim(FileOutput),access="append",action="write")
	write(2,*), "Ended Program"
	close(2)

	!print *, 'promediateCounter = ',promediateCounter

	close(1)
	close(33)
end program ising

V6 Out-Of & On Equilibrium/V6.6 Magnetic Field/ising.f95


subroutine trace_bend_2d(xzt,yzt,xst,yst,ips,	tout)

real xrmin(1000),yrmin(1000)
real t_segm(1000)
integer indexx(100)
real dxtmp(1000),dytmp(1000),xtmp(1000),ytmp(1000)

common/ray_param/ds_ini,ds_segm_min,bend_min0,bend_max0

common/ray/ nodes,xray(1000),yray(1000)
common/ray_part/ npart,xpart(1000),ypart(1000),spart(1000),kod_part(1000)
common/shift/ dxpart(1000),dypart(1000)

totdist=sqrt((xzt-xst)*(xzt-xst)+(yzt-yst)*(yzt-yst))
tout=0

if(totdist.lt.ds_segm_min) then
		x1=xzt
		x2=xst
		xm=(x1+x2)/2.
		y1=yzt
		y2=yst
		ym=(y1+y2)/2.

		vvv=velocity (xm,ym,ips)
		tout=ds/vvv
		return
end if
nsegm_max = int_best(totdist / ds_segm_min)

if(nsegm_max.eq.0) then
	return
end if

call streight_line(xzt,yzt,xst,yst,ips, tout)
!write(*,*)' streight line: tout=',tout
!write(*,*)ds_ini,ds_segm_min,bend_min0,bend_max0
!pause

tmin=tout

do nsegm=1,nsegm_max

!open(22,file='nodes.dat')

	indexx=0
	dpart=1./nsegm
	val_cur0=bend_max0/nsegm
	xtmp=xray
	ytmp=yray

	do iseg=1,nsegm

		part1=(iseg-1)*dpart
		part2=iseg*dpart

		call part_ray(xzt,yzt,xst,yst,part1,part2)
		!write(*,*)' iseg=',iseg,' part1=',part1,' part2=',part2

!write(22,*) xpart(1),ypart(1)
		ttt=0
		do inode=1,npart-1
			x1=xpart(inode)
			x2=xpart(inode+1)
			xm=(x1+x2)/2.
			y1=ypart(inode)
			y2=ypart(inode+1)
			ym=(y1+y2)/2.
			ds=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))
			vvv=velocity (xm,ym,ips)
			ttt=ttt+ds/vvv
			!write(*,*)inode,ypart(inode),dypart(inode),' v=',vvv
		end do
		tini=ttt
		!write(*,*)' tini=',tini,' npart=',npart

		dxpart=0
		dypart=0
		dxtmp=0
		dytmp=0
		valtot=0
		tmin=tini
		t_segm(iseg)=tmin
		val_cur=val_cur0

332		continue
		do icase=1,2
			ind=0
			val_bend = (-1)**icase * val_cur

331			continue
			val = val_bend

			sss2=spart(npart)/2.
			sss=0
			do inode=2,npart-1

				x1=xpart(inode-1)
				y1=ypart(inode-1)
				x2=xpart(inode)
				y2=ypart(inode)
				x3=xpart(inode+1)
				y3=ypart(inode+1)

				ds=sqrt((x2-x1)**2+(y2-y1)**2)
				sss=sss+ds

				dx=x3-x1
				dy=y3-y1
				ds2=sqrt(dx*dx+dy*dy)

				d_value = val * (1-abs(sss-sss2)/sss2)

				dxtmp(inode)= - d_value * dy / ds2
				dytmp(inode)=   d_value * dx / ds2
				!write(*,*)inode,d_value,dxpart(inode),dypart(inode)

			end do

			ttt=0
			sss=0
			do inode=1,npart-1
				x1=	xpart(inode)+	dxpart(inode)+		dxtmp(inode)
				x2=	xpart(inode+1)+	dxpart(inode+1)+	dxtmp(inode+1)
				xm=(x1+x2)/2.

				y1=	ypart(inode)+	dypart(inode)+		dytmp(inode)
				y2=	ypart(inode+1)+	dypart(inode+1)+	dytmp(inode+1)
				ym=(y1+y2)/2.

				ds=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))

				sss=sss+ds
				vvv=velocity (xm,ym,ips)
				ttt=ttt+ds/vvv
				!write(*,*)inode,ypart(inode),dypart(inode),' v=',vvv
			end do

			tout=ttt
			!write(*,*)' val_bend=',val_bend,' tout=',tout

			if(tout.lt.tmin) then
				ind=ind+1
				tmin=tout
				dxpart=dxpart+dxtmp
				dypart=dypart+dytmp
				valtot=valtot+val_bend
				!write(*,*)' valtot=',valtot,' val_bend=',val_bend,' tmin=',tmin
				goto 331
			else
				if(ind.ne.0) exit
			end if

		end do

		val_cur = val_cur / 2.
		if(abs(val_cur).gt.bend_min0) goto 332

		do ipp=1,npart
			kod=kod_part(ipp)
			if(kod.eq.0) cycle
			xtmp(kod)=xtmp(kod)+dxpart(ipp)
			ytmp(kod)=ytmp(kod)+dypart(ipp)
			xpart(ipp)=xpart(ipp)+dxpart(ipp)
			ypart(ipp)=ypart(ipp)+dypart(ipp)
		end do
		t_segm(iseg)=tmin

	end do

333	continue
	ttot=0
	do iseg=1,nsegm
		!write(*,*)' indexx(ip)=',indexx(ip)
		ttot=ttot+t_segm(iseg)
	end do

!write(22,*)xray(nodes),yray(nodes)
!close(22)

	xray=xtmp
	yray=ytmp
	!write(*,*)' val_cur0=',val_cur0,' ttot=',ttot

	nrefl=0
	call remeshing(nrefl)

	!open(21,file='ray_iter.bln')
	!write(21,*)nodes
	!do i=1,nodes
		!write(21,*)xray(i),yray(i)
	!end do
	!close(21)
	!pause

end do
tout=ttot

ttt=0
sss=0
do inode=1,nodes-1
	x1=	xray(inode)
	x2=	xray(inode+1)
	xm=(x1+x2)/2.

	y1=	yray(inode)
	y2=	yray(inode+1)
	ym=(y1+y2)/2.

	ds=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))

	sss=sss+ds

	vvv=velocity (xm,ym,ips)
	!dv= dv_mod_2d(xm,ym)

!	write(*,*)xm,ym,' vvv=',vvv
	!call vel_mod_2d(xm,ym, dv000,dv060,dv120)
	!write(*,*)' dv000=',dv000,' dv060=',dv060,' dv120=',dv120

	ttt=ttt+ds/vvv
	!write(*,*)inode,ypart(inode),dypart(inode),' v=',vvv
end do

tout=ttt

return
end


subroutine synop_check(mlon, mlat, n_max, minlon, minlat, n_min, mtype)

  use types, only: wp
  use constants, only: pi, ra, rkilo
  use params, only: proj, r_ec
  use utils, only: great_circle

  implicit none

  integer    , intent(in)    :: n_max
  integer    , intent(in)    :: n_min
  real   (wp), intent(in)    :: mlon(n_max)
  real   (wp), intent(in)    :: mlat(n_max)
  real   (wp), intent(in)    :: minlon(n_min)
  real   (wp), intent(in)    :: minlat(n_min)
  integer    , intent(inout) :: mtype(n_max)
  ! Local variables
  integer                    :: i_max, i_min
  real   (wp)                :: dist
  logical                    :: flag_synop(n_max)

  dist = 0.

  flag_synop = .false.

  do i_max = 1, n_max
    if (mtype(i_max) >= 1) then

      do i_min = 1, n_min
        if (proj==1) then
          dist = great_circle(mlon(i_max), minlon(i_min), &
                            & mlat(i_max), minlat(i_min), ra)
        elseif(proj==2)then
          dist = sqrt((mlon(i_max) - minlon(i_min))**2 &
                   & +(mlat(i_max) - minlat(i_min))**2)
        endif

        if (dist < r_ec * rkilo) flag_synop(i_max) = .true.
      enddo

      if (mtype(i_max) >= 2 .and. .not. flag_synop(i_max)) then
        mtype(i_max) = mtype(i_max) - 2
      endif
    endif
  enddo

end subroutine synop_check


Module fft_module

  Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

  Implicit None

  Public :: fft_fft3d

  Private

  Integer, Parameter :: long = Selected_int_kind( 12 )

  Interface
     Subroutine dfftw_plan_dft_3d( plan, k1, k2, k3, a, b, dir, method )
       Use, Intrinsic :: iso_fortran_env, Only :  wp => real64
       Implicit None
       Integer, Parameter :: long = Selected_int_kind( 12 )
       Integer( long )                             , Intent(   Out ) :: plan
       Integer                                     , Intent( In    ) :: k1
       Integer                                     , Intent( In    ) :: k2
       Integer                                     , Intent( In    ) :: k3
       Complex( wp ), Dimension( 1:k1, 1:k2, 1:k3 ), Intent( In    ) :: a
       Complex( wp ), Dimension( 1:k1, 1:k2, 1:k3 ), Intent( In    ) :: b
       Integer                                     , Intent( In    ) :: dir
       Integer                                     , Intent( In    ) :: method
     End Subroutine dfftw_plan_dft_3d
     Subroutine dfftw_destroy_plan( plan )
       Use, Intrinsic :: iso_fortran_env, Only :  wp => real64
       Implicit None
       Integer, Parameter :: long = Selected_int_kind( 12 )
       Integer( long ), Intent( InOut ) :: plan
     End Subroutine dfftw_destroy_plan
     Subroutine dfftw_execute( plan )
       Use, Intrinsic :: iso_fortran_env, Only :  wp => real64
       Implicit None
       Integer, Parameter :: long = Selected_int_kind( 12 )
       Integer( long ), Intent( InOut ) :: plan
     End Subroutine dfftw_execute
  End Interface

Contains

  Subroutine fft_fft3d( direction, data )

    Integer                             , Intent( In    ) :: direction
    Complex( wp ), Dimension( :, :, :  ), Intent( InOut ) :: data

    Integer( long ) :: plan

    Integer :: k1, k2, k3

    k1 = Size( data, Dim = 1 )
    k2 = Size( data, Dim = 2 )
    k3 = Size( data, Dim = 3 )

    Select Case( direction )

    Case( 1 )
       Call dfftw_plan_dft_3d( plan, k1, k2, k3, data, data,  1, 64 )
       Call dfftw_execute( plan )
       Call dfftw_destroy_plan( plan )

    Case( -1 )
       Call dfftw_plan_dft_3d( plan, k1, k2, k3, data, data, -1, 64 )
       Call dfftw_execute( plan )
       Call dfftw_destroy_plan( plan )

    Case Default
       Stop "FFT does not know if it is coming or going !!"

    End Select

  End Subroutine fft_fft3d

End Module fft_module


c gmm01f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
      SUBROUTINE abMiexud(X,REFREL,NP,NMAX,NM,AN,BN,NADD,
     +                    RSR,RSI,RSX,PX,AR,AI,BR,BI,EPS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      integer NMAX,NM,NADD,NSTOP,NX,K,N
      COMPLEX*16 REFREL,AN(NP),BN(NP)
      DOUBLE PRECISION AR(NP),AI(NP),BR(NP),BI(NP),
     +   RSR(NMAX),RSI(NMAX),RSX(NMAX),PX(NMAX)
      IF(EPS.GT.1.D0.OR.EPS.LT.0.D0) EPS=1.0D-20
      IF(NADD.NE.0) EPS=0.D0
      CTC=EPS
      XM=DBLE(REFREL)
      YM=DIMAG(REFREL)
      XMX=X*XM
      YMX=X*YM
      RP2=XMX*XMX+YMX*YMX
      NSTOP=X+4.D0*X**.3333D0
      NSTOP=NSTOP+2
      NM=NSTOP+NADD
      XN=DSQRT(XM**2+YM**2)*X
      NX=1.1D0*XN+10.D0
      if(NX-NM.lt.10) NX=NM+10
      write(6,*) 'Wiscombe criterion:',NSTOP
      write(6,*) 'NADD:',NADD
      write(6,*) 'NX:',NX
      IF(NX.GT.NMAX) THEN
         WRITE(6,*) 'Parameter NXMAX too small'
         WRITE(6,*) '  NXMAX must be greater than', NX
         WRITE(6,*) 'Please correct NXMAX in main code,'
         WRITE(6,*) '  recompile, then try again'
         STOP
      ENDIF
      IF(NM.GT.NP) THEN
         WRITE(6,*) 'Parameter np too small'
         WRITE(6,*) '  np must be greater than', NM
         WRITE(6,*) 'Please correct np in gmm01f.par,'
         WRITE(6,*) '  recompile the code, then try again'
         STOP
      ENDIF
C  DOWN RECURSION FOR RATIOS RSR,RSI,RSX,PNR,PNI,PX
      PNX=X/DBLE(2*NX+3)
      PNR=XMX/DBLE(2*NX+3)
      PNI=YMX/DBLE(2*NX+3)
      DO 5 K=1,NX
         N=NX-K+1
         CN=DBLE(N)
         ALN=(2.D0*CN+1.D0)*XMX/RP2-PNR
         BEN=(2.D0*CN+1.D0)*YMX/RP2+PNI
         RSR(N)=-CN*XMX/RP2+ALN
         RSI(N)=CN*YMX/RP2-BEN
         PZD=ALN*ALN+BEN*BEN
         PNR=ALN/PZD
         PNI=BEN/PZD
         RSX(N)=(CN+1.D0)/X-PNX
         IF(N.EQ.1) GO TO 20
         PNX=X/(2.D0*CN+1.D0-PNX*X)
         PX(N)=PNX
    5    CONTINUE
   20 SNM1X=DSIN(X)
      CNM1X=DCOS(X)
      IF(X-0.1D0)21,22,22
   21 SNX=X**2./3.D0-X**4./30.D0+X**6./840.D0-X**8./45360.D0
      GO TO 23
   22 SNX=SNM1X/X-CNM1X
   23 CNX=CNM1X/X+SNM1X
      DO 10 N=1,NX
         PX(N)=SNX      !preparing for the calculation of Cabs
         C=DBLE(N)
         DCNX=CNM1X-C*CNX/X
         DSNX=RSX(N)*SNX
C  CALCULATION OF EXTERIOR COEFFICIENTS AN AND BN
         ANNR=RSR(N)*SNX-XM*DSNX
         ANNI=RSI(N)*SNX-YM*DSNX
         TA1=RSR(N)*SNX-RSI(N)*CNX
         TA2=RSI(N)*SNX+RSR(N)*CNX
         ANDR=TA1-XM*DSNX+YM*DCNX
         ANDI=TA2-XM*DCNX-YM*DSNX
         AND=ANDR*ANDR+ANDI*ANDI
         BNNR=(XM*RSR(N)-YM*RSI(N))*SNX-DSNX
         BNNI=(XM*RSI(N)+YM*RSR(N))*SNX
         TB1=RSR(N)*SNX-RSI(N)*CNX
         TB2=RSR(N)*CNX+RSI(N)*SNX
         BNDR=XM*TB1-YM*TB2-DSNX
         BNDI=XM*TB2+YM*TB1-DCNX
         BND=BNDR*BNDR+BNDI*BNDI
         AR(N)=(ANNR*ANDR+ANNI*ANDI)/AND
         AI(N)=(ANNI*ANDR-ANNR*ANDI)/AND
         BR(N)=(BNNR*BNDR+BNNI*BNDI)/BND
         BI(N)=(BNNI*BNDR-BNNR*BNDI)/BND
C  MIE SERIES CONVERGENCE TEST IS MADE BY TESTING AN'S AND BN'S
         TI=AR(N)*AR(N)+AI(N)*AI(N)+BR(N)*BR(N)+BI(N)*BI(N)
         TI=TI/(AR(1)*AR(1)+AI(1)*AI(1)+BR(1)*BR(1)+BI(1)*BI(1))
         IF(TI-CTC) 16,18,18
   18    IF(NM-N) 15,15,6
    6    IF(N-NX)7,15,15
    7    M=N+1
         SNX=PX(M)*SNX
         CNM2X=CNM1X
         CNM1X=CNX
         CNX=(2.D0*C+1.D0)*CNM1X/X-CNM2X
   10 CONTINUE
      GO TO 15
   16 WRITE(6,*) '*** NOTE THAT THE FIELD-EXPANSION TRANCATION'
      WRITE(6,*) '*** IS DETERMINED BY eps GIVEN IN THE INPUT'
      WRITE(6,*) '*** FILE gmm01f.in'
      WRITE(6,*) '*** IN CASE YOU NEED A HIGHER ORDER, eps MUST'
      WRITE(6,'(a,e9.1)')
     +          ' *** BE SMALLER THAN THE CURRENT VALUE',EPS
   15 NM=N
      DO I=1,NM
         AN(I)=DCMPLX(AR(I),-AI(I))
         BN(I)=DCMPLX(BR(I),-BI(I))
      ENDDO
      RETURN
      END


C
C $Id: phi3dp.f,v 1.5 2008-07-27 00:17:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION PHI3DP (ML,E0,E1,E2,E3)
C
C FUNCTION TO COMPUTE LATITUDE ANGLE (PHI-3).
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      INTEGER II,NIT
      COMMON /ERRMZ0/ IERR
        INTEGER IERR
      SAVE   /ERRMZ0/
      COMMON /PRINZ0/ IPEMSG,IPELUN,IPPARM,IPPLUN
        INTEGER IPEMSG,IPELUN,IPPARM,IPPLUN
      SAVE   /PRINZ0/
      DATA TWO,FOUR,SIX /2.0D0,4.0D0,6.0D0/
      DATA TOL,NIT /1.0D-10,15/
C
      PHI = ML
      DO 020 II = 1,NIT
      DPHI = (ML + E1 * SIN (TWO * PHI) - E2 * SIN (FOUR * PHI)
     .       + E3 * SIN (SIX * PHI)) / E0 - PHI
      PHI = PHI + DPHI
      IF (ABS(DPHI) .GT. TOL) GO TO 020
      PHI3DP = PHI
      RETURN
  020 CONTINUE
C
      IF (IPEMSG .EQ. 0) WRITE (IPELUN,2000) NIT,ML,E0,E1,E2,E3
 2000 FORMAT (/' ERROR PHI3DP' /
     .         ' LATITUDE FAILED TO CONVERGE AFTER',I3,' ITERATIONS'/
     .         ' ML =',E25.16,'   E0 =',E25.16/
     .         ' E1 =',E25.16,'   E2 =',E25.16,'   E3=',E25.16)
      IERR = 003
      RETURN
C
      END


      double complex function ehsva4_dm(s,t,u,s34)
C     ehsv:EqnA.8
      implicit none
      double precision s,t,u,s34
      double complex ehsvb4_dm
      ehsva4_dm=ehsvb4_dm(s,t,u,s34)+ehsvb4_dm(u,s,t,s34)
     &     +ehsvb4_dm(t,u,s,s34)
      return
      end

      double complex function ehsva2_dm(s,t,u,s34)
C     ehsv:EqnA.9
      implicit none
      double precision s,t,u,s34
      double complex ehsvb2_dm
      ehsva2_dm=ehsvb2_dm(s,t,u,s34)+ehsvb2_dm(s,u,t,s34)
      return
      end

      double complex function ehsvb4_dm(s,t,u,s34)
      implicit none
C     ehsv:EqnA.10
      include 'masses.f'
      double precision hmass2,s,t,u,s34
      double complex w2,w3

      hmass2=s34
c--- The Fermilab preprint has w2(s), but it makes no difference due
c---  to symmetrization in ehsva4 above
      ehsvb4_dm=mbsq/hmass2*(-2d0/3d0
     . +(mbsq/hmass2-0.25d0)*(w2(t)-w2(hmass2)+w3(s,t,u,hmass2)))
      return
      end

      double complex function ehsvb2_dm(s,t,u,s34)
C     ehsv:EqnA.11
      implicit none
      include 'masses.f'
      double precision hmass2,s,t,u,s34
      double complex w1,w2,w3
      hmass2=s34
      ehsvb2_dm=mbsq/hmass2**2*(s*(u-s)/(s+u)
     . +2d0*u*t*(u+2d0*s)/(s+u)**2*(w1(t)-w1(hmass2))
     . +(mbsq-0.25d0*s)
     . *(0.5d0*w2(s)+0.5d0*w2(hmass2)-w2(t)+w3(s,t,u,hmass2))
     . +s**2*(2d0*mbsq/(s+u)**2-0.5d0/(s+u))*(w2(t)-w2(hmass2))
     . +0.5d0*u*t/s*(w2(hmass2)-2d0*w2(t))
     . +0.125d0*(s-12d0*mbsq-4d0*u*t/s)*w3(t,s,u,hmass2))
      return
      end

      double complex function ehsva5_dm(s,t,u,s34)
C     ehsv:EqnA.14
      implicit none
      include 'masses.f'
      double precision hmass2,s,t,u,s34
      double complex w1,w2
      hmass2=s34
      ehsva5_dm=mbsq/hmass2*(4d0+4d0*s/(u+t)*(w1(s)-w1(hmass2))
     . +(1d0-4d0*mbsq/(u+t))*(w2(s)-w2(hmass2)))
      return
      end


program main
    use iso_c_binding
    use spfft
    implicit none
    integer :: i, j, k, counter
    integer, parameter :: dimX = 2
    integer, parameter :: dimY = 2
    integer, parameter :: dimZ = 2
    integer, parameter :: maxNumLocalZColumns = dimX * dimY
    integer, parameter :: processingUnit = 1
    integer, parameter :: maxNumThreads = -1
    type(c_ptr) :: grid = c_null_ptr
    type(c_ptr) :: transform = c_null_ptr
    integer :: errorCode = 0
    integer, dimension(dimX * dimY * dimZ * 3):: indices = 0
    complex(C_DOUBLE_COMPLEX), dimension(dimX * dimY * dimZ):: frequencyElements
    real(C_DOUBLE), dimension(2*dimX * dimY * dimZ):: spaceDomain
    complex(C_DOUBLE_COMPLEX), pointer :: spaceDomainPtr(:,:,:)
    type(c_ptr) :: realValuesPtr

    counter = 0
    do k = 1, dimZ
        do j = 1, dimY
            do i = 1, dimX
             frequencyElements(counter + 1) = cmplx(counter, -counter)
             indices(counter * 3 + 1) = i - 1
             indices(counter * 3 + 2) = j - 1
             indices(counter * 3 + 3) = k - 1
             counter = counter + 1
            end do
        end do
    end do

    ! print input
    print *, "Input:"
    do i = 1, size(frequencyElements)
         print *, frequencyElements(i)
    end do

    ! create grid
    errorCode = spfft_grid_create(grid, dimX, dimY, dimZ, maxNumLocalZColumns, processingUnit, maxNumThreads);
    if (errorCode /= SPFFT_SUCCESS) error stop

    ! create transform
    ! Note: A transform handle can be created without a grid if no resource sharing is desired.
    errorCode = spfft_transform_create(transform, grid, processingUnit, 0, dimX, dimY, dimZ, dimZ,&
        size(frequencyElements), SPFFT_INDEX_TRIPLETS, indices)
    if (errorCode /= SPFFT_SUCCESS) error stop

    ! grid can be safely destroyed after creating all required transforms
    errorCode = spfft_grid_destroy(grid)
    if (errorCode /= SPFFT_SUCCESS) error stop

    ! *************************************************
    ! Option A: Reuse internal buffer for space domain
    ! *************************************************

    ! set space domain array to use memory allocted by the library
    errorCode = spfft_transform_get_space_domain(transform, processingUnit, realValuesPtr)
    if (errorCode /= SPFFT_SUCCESS) error stop

    ! transform backward
    errorCode = spfft_transform_backward(transform, frequencyElements, processingUnit)
    if (errorCode /= SPFFT_SUCCESS) error stop

    call c_f_pointer(realValuesPtr, spaceDomainPtr, [dimX,dimY,dimZ])

    print *, ""
    print *, "After backward transform:"
    do k = 1, size(spaceDomainPtr, 3)
        do j = 1, size(spaceDomainPtr, 2)
            do i = 1, size(spaceDomainPtr, 1)
             print *, spaceDomainPtr(i, j, k)
            end do
        end do
    end do

    ! **********************************************
    ! Option B: Use external buffer for space domain
    ! **********************************************

    ! transform backward
    errorCode = spfft_transform_backward_ptr(transform, frequencyElements, spaceDomain)
    if (errorCode /= SPFFT_SUCCESS) error stop

    ! transform forward
    errorCode = spfft_transform_forward_ptr(transform, spaceDomain, frequencyElements, SPFFT_NO_SCALING)
    if (errorCode /= SPFFT_SUCCESS) error stop

    print *, ""
    print *, "After forward transform (without normalization):"
    do i = 1, size(frequencyElements)
             print *, frequencyElements(i)
    end do

    ! destroying the final transform will free the associated memory
    errorCode = spfft_transform_destroy(transform)
    if (errorCode /= SPFFT_SUCCESS) error stop

end


submodule(euler_interface_m) euler_prob_0040_m
    implicit none

contains

    module character(len=20) function euler0040()
        write (euler0040, "(i20)") ans()
    end function euler0040

    integer function ans()
        integer, allocatable :: arr(:)
        integer :: dig_arr(6), d(6), i, s

        dig_arr = [0, 9, 189, 2889, 38889, 488889]
        d = [(1, i=1, 6)]

        do i = 2, 6
            associate (x => floor(real((10**i - dig_arr(i))/i), sp))
                d(i) = x + 10**(i - 1) - 1
            end associate

            call int_2_arr(d(i), arr)
            s = mod(10**i - dig_arr(i), i)
            d(i) = arr(s)
            deallocate (arr)
        end do

        ans = product(d)
    end function ans

end submodule euler_prob_0040_m


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE PRINCIPAL_2D ( SX, SY, SXY, ANGLE, SMAJOR, SMINOR, SXYMAX, MEAN, VONMISES )

! Calculates principal stresses or strains for 2-D shell elems:

!     (a) If SX, SY, SXY inputs are stress then outputs are stress.
!     (b) If SX, SY, SXY inputs are strain then outputs are strain

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTS_1, ONLY           :  ZERO, QUARTER, HALF, TWO, ONEPM6, FORTY5, CONV_RAD_DEG
      USE SUBR_BEGEND_LEVELS, ONLY    :  PRINCIPAL_2D_BEGEND

      USE PRINCIPAL_2D_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'PRINCIPAL_2D'

      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = PRINCIPAL_2D_BEGEND

      REAL(DOUBLE), INTENT(IN)        :: SX                 ! Normal x stress or strain
      REAL(DOUBLE), INTENT(IN)        :: SY                 ! Normal y stress or strain
      REAL(DOUBLE), INTENT(IN)        :: SXY                ! Shear stress or strain
      REAL(DOUBLE), INTENT(OUT)       :: ANGLE              ! Angle of principal stresses or strain
      REAL(DOUBLE), INTENT(OUT)       :: MEAN               ! Mean stresses or strain
      REAL(DOUBLE), INTENT(OUT)       :: SMAJOR             ! Major principal stress or strain
      REAL(DOUBLE), INTENT(OUT)       :: SMINOR             ! Minor principal stress or strain
      REAL(DOUBLE), INTENT(OUT)       :: SXYMAX             ! Max shear stress or strain
      REAL(DOUBLE), INTENT(OUT)       :: VONMISES           ! von Mises stress or strain
      REAL(DOUBLE)                    :: DENR               ! Denominator in arctan calculation of ANGLE
      REAL(DOUBLE), PARAMETER         :: EPS2    = ONEPM6   ! Small number to compare with ADENR, ANUMR when calculating ANGLE
      REAL(DOUBLE)                    :: SAVG               ! Average of SX and SY
      REAL(DOUBLE)                    :: NUMR               ! Numerator in arctan calculation of ANGLE
      REAL(DOUBLE)                    :: ADENR              ! DABS(DENR)
      REAL(DOUBLE)                    :: ANUMR              ! DABS(NUMR)

      INTRINSIC                       :: DABS, DATAN2, DSQRT

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Initialize outputs

      ANGLE  = ZERO
      SMINOR = ZERO
      SXYMAX = ZERO

! Calc outputs

      DENR     = SX - SY
      NUMR     = TWO*SXY
      ADENR    = DABS(DENR)
      ANUMR    = DABS(NUMR)

! Calculate angle for principal axes.

      IF ((ADENR <= EPS2) .AND. (ANUMR <= EPS2)) THEN
         ANGLE = ZERO
      ELSE IF ((ADENR <= EPS2) .AND. (ANUMR > EPS2)) THEN
         ANGLE = FORTY5
      ELSE
         ANGLE = (HALF*DATAN2(NUMR,DENR))*CONV_RAD_DEG
      ENDIF

! Calculate the principal stresses and max shear

      SXYMAX = DSQRT(QUARTER*DENR*DENR + SXY*SXY)
      SAVG   = HALF*(SX + SY)
      SMAJOR = SAVG + SXYMAX
      SMINOR = SAVG - SXYMAX

! Calculate mean andvon Mises stress for 2D stress state

      MEAN     = HALF*(SMAJOR + SMINOR)
      VONMISES = DSQRT( SMAJOR*SMAJOR - SMAJOR*SMINOR + SMINOR*SMINOR)

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************

      END SUBROUTINE PRINCIPAL_2D


module pdt_mod ! GitHub FortranTip pdt_matrix.f90
integer, parameter :: nlen = 20, sp = kind(1.0)
!
type, public :: data_frame(n1,n2,wp)
! n1 by n2 matrix of reals of kind wp with row and column names
integer, len         :: n1=100,n2=100  ! dimensions of x(:,:)
! below, wp is set to single precision kind by default
integer, kind        :: wp = kind(1.0) ! kind of x(:,:)
real(kind=wp)        :: x(n1,n2)
character (len=nlen) :: row_names(n1),col_names(n2)
end type data_frame
!
contains
subroutine display(df)
! dimensions of data_frame can be assumed, but not kind
type(data_frame(*,*,sp)), intent(in) :: df
integer                              :: i
print "(6x,*(a8))","",df%col_names
do i=1,df%n1
   print "(a8,*(f8.4))",df%row_names(i),df%x(i,:)
end do
end subroutine display

end module pdt_mod
!
program test_data_frame
use pdt_mod, only: data_frame, display
implicit none
integer, parameter :: dp = kind(1.0d0), sp = kind(1.0), &
                      n1 = 2, n2 = 3
type(data_frame(n1,n2,dp))            :: df ! df%n1, df%n2 fixed
type(data_frame)                      :: ds
! ds takes the default values of n1, n2, wp since they are unspecified
type(data_frame(:,:,sp)), allocatable :: da ! da%n1, da%n2 set later
character (len=20)                    :: fmt_ci = "(a,*(1x,i0))"
print fmt_ci, &
 "shape(df%x), size(df%row_names), size(df%col_names) =", &
  shape(df%x), size(df%row_names), size(df%col_names)
! KIND and LEN parameters can be accessed as follows:
print fmt_ci,"df%n1, df%n2, df%wp=",df%n1,df%n2,df%wp
print fmt_ci,"ds%n1, ds%n2, ds%wp=",ds%n1,ds%n2,ds%wp
allocate (data_frame(n1,n2,sp) :: da)
print fmt_ci,"shape(da%x), kind(da%x) =",shape(da%x),kind(da%x)
call random_number(da%x)
da%row_names=["r1","r2"] ; da%col_names = ["c1","c2","c3"]
call display(da)
end program test_data_frame
! gfortran 12.0.1 cannot compile the display() subroutine
! Intel Fortran sample output:
! shape(df%x), size(df%row_names), size(df%col_names) = 2 3 2 3
! df%n1, df%n2, df%wp= 2 3 8
! ds%n1, ds%n2, ds%wp= 100 100 4
! shape(da%x), kind(da%x) = 2 3 4
!               c1      c2      c3
! r1        0.0000  0.3525  0.9631
! r2        0.0255  0.6669  0.8383


module OMSAO_lininterpolation_module

  !F90---------------------------------------------------------------------------!
  !
  !Description:
  ! This module consists of linear interpolation functions for 1 to 7 dimensions.
  ! Lininterpol is the only interface that can be called from ouside the module.
  !
  !Input:
  ! linInterpol:
  ! dim1, .., dimn            : number of nodes in dimension i
  ! dimscale1, .., dimscalen  : dimension scale of the nodes
  ! datand                    : data to be interpolated
  ! x1, .., xn                : value of each dimension to interpolate to
  ! node1_in, ..,noden_in     ! nodes for all dimensions (optional input)
  ! status                    : return status: 0 if succes; -1 if fail
  !
  !Output:
  !
  !Input/Output:
  ! linInterpol:
  ! returns the interpolated value.
  !
  !Revision History:
  ! nodes are optional input,   Roeland van Oss, 26/02/2003
  ! Changed real into REAL(SP) and introduced USE constants, ONLY : SP
  ! Roeland van Oss,,17/05/2002
  ! Version 1.0 07/01/2002
  ! Developed by J.P. Veefkind, KNMI (veefkind@knmi.nl)
  !
  !OMI-KNMI header:
  !
  ! CfA Revision history:
  ! Modified to suit OMSAO OMI applications (gga June 2013)
  !  Removed USE constants, ONLE : SP
  !END---------------------------------------------------------------------------!

  implicit none

  INTEGER, PARAMETER :: SP = 8

  interface linInterpol
    module procedure interpol1D
    module procedure interpol2D
    module procedure interpol3D
    module procedure interpol4D
    module procedure interpol5D
    module procedure interpol6D
    module procedure interpol7D
  end interface

  PUBLIC :: GetNode
  private :: monotonDecrease, findNode
  private :: interpol1D, interpol2D, interpol3D, interpol4D, interpol5D, interpol6D, interpol7D

contains

  !==============================================================================!
  logical function monotonIncrease(dimScale,ndim)
    !
    ! checks if array is monotonically increasing
    !
    integer, intent(in) :: ndim
    REAL(SP), dimension(ndim), intent(in) :: dimscale

    if ( minval( dimScale(2:ndim) - dimScale(1:ndim-1)) <= 0. ) then
      monotonIncrease = .FALSE.
    else
      monotonIncrease = .TRUE.
    end if

  end function  monotonIncrease

  !==============================================================================!
  logical function monotonDecrease(dimScale,ndim)
    !
    ! checks if array is monotonically increasing
    !
    integer, intent(in) :: ndim
    REAL(SP), dimension(ndim), intent(in) :: dimscale

    if ( minval( dimScale(2:ndim) - dimScale(1:ndim-1)) >= 0. ) then
      monotonDecrease = .FALSE.
    else
      monotonDecrease = .TRUE.
    end if

  end function  monotonDecrease

  integer function findNode(dimScale, ndim, x)

    integer, intent(in) :: ndim
    REAL(SP), dimension(ndim), intent(in) :: dimscale
    REAL(SP), intent(in) :: x
    integer, dimension(1) :: nearestLocation

    ! check if the dimension scale is monotonically increasing or decreasing
    if (.NOT.monotonIncrease(dimScale,ndim) .and. &
      .NOT.monotonDecrease(dimScale,ndim)) then
      findnode = -2
      return
    end if

    ! deal with two exceptions:
    ! (1) x = dimScale(1)
    ! (2) x = dimScale(ndim)
    if ( x == dimScale(1) ) then
      findNode = 1
      return
    end if

    if ( x == dimScale(ndim) ) then
      findNode = ndim -1
      return
    end if

    ! find the nearest grid point near x
    nearestLocation=minloc(abs(dimscale-x))

    if (dimscale(nearestLocation(1)) > x ) then
      findNode = nearestLocation(1) - 1
    else
      findNode = nearestLocation(1)
    end if

    if (findNode == 0) findnode = -1  ! extrapolation

    if (findNode == ndim) findnode = -1 ! extrapolation

    return

  end function findNode

  !==============================================================================!
  REAL(SP) function interpol1D(dim1, dimScale1, data1D, x1, node1_in, status)

    integer, parameter :: ndim=1

    integer, intent(in) :: dim1
    REAL(SP), dimension(dim1), intent(in) :: dimScale1
    REAL(SP), dimension(dim1), intent(in) :: data1D
    REAL(SP), intent(in) :: x1
    integer, intent(in), OPTIONAL :: node1_in
    integer, intent(out), OPTIONAL :: status

    integer :: node1
    REAL(SP), dimension(ndim) :: distance
    REAL(SP), dimension(2**ndim) :: weights, values
    REAL(SP), dimension(1) :: denominator
    integer :: i
    integer :: npoint
    status = 0 ! set to success

    !adapted by RF van Oss:
    IF ( PRESENT(node1_in) ) THEN
      !nodes are given on input
      node1 = node1_in
    ELSE
      node1 = findNode(dimScale1, dim1, x1)
    ENDIF
    if ( node1 <= 0 ) then ! error getting nodes, exit with error
      status = -1
      interpol1D = -huge(interpol1D)
      return
    end if

    ! No need to recompute dimscale(node1+1) - dimscale1(node1) each time
    denominator(1) = dimscale1(node1+1) - dimscale1(node1)

    npoint = 0
    do i = node1, node1 + 1
      npoint = npoint + 1

      distance(1) = (x1 - dimscale1(i)) / (denominator(1))

      distance = 1. - abs(distance)

      weights(npoint) = product(distance)

      values(npoint) = data1D(i)

    end do

    ! normalize weights
    weights(1:npoint) =  weights(1:npoint) / sum(weights(1:npoint))

    ! determine output
    interpol1D = 0.
    do i=1, npoint
      interpol1D = interpol1D + weights(i) * values(i)
    end do

    return

  end function interpol1D

  !==============================================================================!
  REAL(SP) function interpol2D(dim1, dim2 , &
      dimScale1, dimScale2, &
      data2D, x1, x2, node1_in, node2_in, status)

    integer, parameter :: ndim=2

    integer, intent(in) :: dim1, dim2
    REAL(SP), dimension(dim1), intent(in) :: dimScale1
    REAL(SP), dimension(dim2), intent(in) :: dimScale2
    REAL(SP), dimension(dim1,dim2), intent(in) :: data2D
    REAL(SP), intent(in) :: x1,x2
    integer, intent(in), OPTIONAL :: node1_in, node2_in
    integer, intent(out), OPTIONAL :: status

    integer :: node1, node2
    REAL(SP), dimension(ndim) :: distance
    REAL(SP), dimension(2**ndim) :: weights, values
    REAL(SP), dimension(2) :: denominator
    integer :: i, j
    integer :: npoint

    status = 0 ! set to success

    !adapted by RF van Oss:
    IF ( PRESENT(node1_in) ) THEN
      !nodes are given on input
      node1 = node1_in
      node2 = node2_in
    ELSE
      node1 = findNode(dimScale1, dim1, x1)
      node2 = findNode(dimScale2, dim2, x2)
    ENDIF

    if ( min(node1,node2) <= 0 ) then ! error getting nodes, exit with error
      status = -1
      interpol2D = -huge(interpol2D)
      return
    end if

    denominator(1) = dimscale1(node1+1) - dimscale1(node1)
    denominator(2) = dimscale2(node2+1) - dimscale2(node2)

    npoint = 0
    do i = node1, node1 + 1
      do j=node2, node2 + 1

        npoint = npoint + 1

        distance(1) = (x1 - dimscale1(i)) / (denominator(1))

        distance(2) = (x2 - dimscale2(j)) / (denominator(2))

        distance = 1. - abs(distance)

        weights(npoint) = product(distance)

        values(npoint) = data2D(i,j)

      end do
    end do

    ! normalize weights
    weights(1:npoint) =  weights(1:npoint) / sum(weights(1:npoint))

    ! determine output
    interpol2D = 0.
    do i=1, npoint
      interpol2D = interpol2D + weights(i) * values(i)
    end do

    return

  end function interpol2D

  !==============================================================================!
  REAL(SP) function interpol3D(dim1, dim2, dim3 , &
      dimScale1, dimScale2, dimScale3, &
      data3D, x1, x2, x3, node1_in, node2_in, node3_in, status)

    integer, parameter :: ndim=3

    integer, intent(in) :: dim1, dim2, dim3
    REAL(SP), dimension(dim1), intent(in) :: dimScale1
    REAL(SP), dimension(dim2), intent(in) :: dimScale2
    REAL(SP), dimension(dim3), intent(in) :: dimScale3
    REAL(SP), dimension(dim1,dim2,dim3), intent(in) :: data3D
    REAL(SP), intent(in) :: x1,x2,x3
    integer, intent(in), OPTIONAL :: node1_in, node2_in, node3_in
    integer, intent(out), OPTIONAL :: status

    integer :: node1, node2,node3
    REAL(SP), dimension(ndim) :: distance
    REAL(SP), dimension(2**ndim) :: weights, values
    REAL(SP), dimension(3) :: denominator
    integer :: i, j, k
    integer :: npoint

    status = 0 ! set to success

    !adapted by RF van Oss:
    IF ( PRESENT(node1_in) ) THEN
      !nodes are given on input
      node1 = node1_in
      node2 = node2_in
      node3 = node3_in
    ELSE
      node1 = findNode(dimScale1, dim1, x1)
      node2 = findNode(dimScale2, dim2, x2)
      node3 = findNode(dimScale3, dim3, x3)
    ENDIF

    if ( min(node1,node2,node3) <= 0 ) then ! error getting nodes, exit with error
      status = -1
      interpol3D = -huge(interpol3D)
      return
    end if

    denominator(1) = dimscale1(node1+1) - dimscale1(node1)
    denominator(2) = dimscale2(node2+1) - dimscale2(node2)
    denominator(3) = dimscale3(node3+1) - dimscale3(node3)

    npoint = 0
    do i = node1, node1 + 1
      do j=node2, node2 + 1
        do k=node3, node3 + 1

          npoint = npoint + 1

          distance(1) = (x1 - dimscale1(i)) / (denominator(1))

          distance(2) = (x2 - dimscale2(j)) / (denominator(2))

          distance(3) = (x3 - dimscale3(k)) / (denominator(3))

          distance = 1. - abs(distance)

          weights(npoint) = product(distance)

          values(npoint) = data3D(i,j,k)

        end do
      end do
    end do

    ! normalize weights
    weights(1:npoint) =  weights(1:npoint) / sum(weights(1:npoint))

    ! determine output
    interpol3D = 0.
    do i=1, npoint
      interpol3D = interpol3D + weights(i) * values(i)
    end do

    return

  end function interpol3D

  !==============================================================================!
  REAL(SP) function interpol4D(dim1, dim2, dim3 , dim4, &
      dimScale1, dimScale2, dimScale3, dimScale4, &
      data4D, x1, x2, x3, x4,&
      node1_in, node2_in, node3_in, node4_in,  &
      status)

    integer, parameter :: ndim=4

    integer, intent(in) :: dim1, dim2, dim3, dim4
    REAL(SP), dimension(dim1), intent(in) :: dimScale1
    REAL(SP), dimension(dim2), intent(in) :: dimScale2
    REAL(SP), dimension(dim3), intent(in) :: dimScale3
    REAL(SP), dimension(dim4), intent(in) :: dimScale4
    REAL(SP), dimension(dim1,dim2,dim3,dim4), intent(in) :: data4D
    REAL(SP), intent(in) :: x1,x2,x3,x4
    integer, intent(in), OPTIONAL :: node1_in, node2_in, node3_in, node4_in
    integer, intent(out), OPTIONAL :: status

    integer :: node1, node2,node3,node4
    REAL(SP), dimension(ndim) :: distance
    REAL(SP), dimension(2**ndim) :: weights, values
    REAL(SP), dimension(4) :: denominator
    integer :: i, j, k,l
    integer :: npoint

    status = 0 ! set to success

    !adapted by RF van Oss:
    IF ( PRESENT(node1_in) ) THEN
      !nodes are given on input
      node1 = node1_in
      node2 = node2_in
      node3 = node3_in
      node4 = node4_in
    ELSE
      node1 = findNode(dimScale1, dim1, x1)
      node2 = findNode(dimScale2, dim2, x2)
      node3 = findNode(dimScale3, dim3, x3)
      node4 = findNode(dimScale4, dim4, x4)
    ENDIF

    if ( min(node1,node2,node3,node4) <= 0 ) then ! error getting nodes, exit with error
      status = -1
      interpol4D = -huge(interpol4D)
      return
    end if

    denominator(1) = dimscale1(node1+1) - dimscale1(node1)
    denominator(2) = dimscale2(node2+1) - dimscale2(node2)
    denominator(3) = dimscale3(node3+1) - dimscale3(node3)
    denominator(4) = dimscale4(node4+1) - dimscale4(node4)

    npoint = 0
    do i = node1, node1 + 1
      do j=node2, node2 + 1
        do k=node3, node3 + 1
          do l=node4, node4 + 1

            npoint = npoint + 1

            distance(1) = (x1 - dimscale1(i)) / (denominator(1))

            distance(2) = (x2 - dimscale2(j)) / (denominator(2))

            distance(3) = (x3 - dimscale3(k)) / (denominator(3))

            distance(4) = (x4 - dimscale4(l)) / (denominator(4))

            distance = 1. - abs(distance)

            weights(npoint) = product(distance)

            values(npoint) = data4D(i,j,k,l)

          end do
        end do
      end do
    end do

    ! normalize weights
    weights(1:npoint) =  weights(1:npoint) / sum(weights(1:npoint))

    ! determine output
    interpol4D = 0.
    do i=1, npoint
      interpol4D = interpol4D + weights(i) * values(i)
    end do

    return

  end function interpol4D

  !==============================================================================!
  REAL(SP) function interpol5D( &
      dim1, dim2, dim3 , dim4, dim5,&
      dimScale1, dimScale2, dimScale3, dimScale4, dimscale5, &
      data5D, &
      x1, x2, x3, x4, x5, &
      node1_in, node2_in, node3_in, node4_in, node5_in, &
      status)

    integer, parameter :: ndim=5

    !INPUT
    integer, intent(in) :: dim1, dim2, dim3, dim4, dim5
    REAL(SP), dimension(dim1), intent(in) :: dimScale1
    REAL(SP), dimension(dim2), intent(in) :: dimScale2
    REAL(SP), dimension(dim3), intent(in) :: dimScale3
    REAL(SP), dimension(dim4), intent(in) :: dimScale4
    REAL(SP), dimension(dim5), intent(in) :: dimScale5
    REAL(SP), dimension(dim1,dim2,dim3,dim4,dim5), intent(in) :: data5D
    REAL(SP), intent(in) :: x1,x2,x3,x4,x5
    integer, intent(in), OPTIONAL :: node1_in, node2_in, node3_in, node4_in, node5_in
    integer, intent(out), OPTIONAL  :: status

    !LOCAL
    integer :: node1, node2, node3, node4, node5
    REAL(SP), dimension(ndim) :: distance
    REAL(SP), dimension(2**ndim) :: weights, values
    REAL(SP), dimension(5) :: denominator
    integer :: i, j, k, l, m
    integer :: npoint

    status = 0 ! set to success

    !adapted by RF van Oss:
    IF ( PRESENT(node1_in) ) THEN
      !nodes are given on input
      node1 = node1_in
      node2 = node2_in
      node3 = node3_in
      node4 = node4_in
      node5 = node5_in
    ELSE
      node1 = findNode(dimScale1, dim1, x1)
      node2 = findNode(dimScale2, dim2, x2)
      node3 = findNode(dimScale3, dim3, x3)
      node4 = findNode(dimScale4, dim4, x4)
      node5 = findNode(dimScale5, dim5, x5)
    ENDIF

    if ( min(node1,node2,node3,node4,node5) <= 0 ) then
      !invalid nodes, exit with error
      status = -1
      interpol5D = -huge(interpol5D)
      return
    end if

    if ( min(dim1-node1,dim2-node2,dim3-node3,dim4-node4,dim5-node5) <= 0 ) then
      !invalid nodes, exit with error
      status = -2
      interpol5D = -huge(interpol5D)
      return
    end if

    denominator(1) = dimscale1(node1+1) - dimscale1(node1)
    denominator(2) = dimscale2(node2+1) - dimscale2(node2)
    denominator(3) = dimscale3(node3+1) - dimscale3(node3)
    denominator(4) = dimscale4(node4+1) - dimscale4(node4)
    denominator(5) = dimscale5(node5+1) - dimscale5(node5)

    npoint = 0
    do i = node1, node1 + 1
      do j=node2, node2 + 1
        do k=node3, node3 + 1
          do l=node4, node4 + 1
            do m=node5, node5 + 1

              npoint = npoint + 1

              distance(1) = (x1 - dimscale1(i)) / (denominator(1))

              distance(2) = (x2 - dimscale2(j)) / (denominator(2))

              distance(3) = (x3 - dimscale3(k)) / (denominator(3))

              distance(4) = (x4 - dimscale4(l)) / (denominator(4))

              distance(5) = (x5 - dimscale5(m)) / (denominator(5))

              distance = 1. - abs(distance)

              weights(npoint) = product(distance)

              values(npoint) = data5D(i,j,k,l,m)

            end do
          end do
        end do
      end do
    end do

    ! normalize weights
    weights(1:npoint) =  weights(1:npoint) / sum(weights(1:npoint))

    ! determine output
    interpol5D = 0.
    do i=1, npoint
      interpol5D = interpol5D + weights(i) * values(i)
    end do

    return

  end function interpol5D

  !==============================================================================!
  REAL(SP) function interpol6D(dim1, dim2, dim3 , dim4, dim5, dim6, &
      dimScale1, dimScale2, dimScale3, dimScale4, dimscale5, dimscale6, &
      data6D, &
      x1, x2, x3, x4, x5, x6, &
      node1_in, node2_in, node3_in, node4_in, node5_in, node6_in,&
      status)

    integer, parameter :: ndim=6

    integer, intent(in) :: dim1, dim2, dim3, dim4, dim5, dim6
    REAL(SP), dimension(dim1), intent(in) :: dimScale1
    REAL(SP), dimension(dim2), intent(in) :: dimScale2
    REAL(SP), dimension(dim3), intent(in) :: dimScale3
    REAL(SP), dimension(dim4), intent(in) :: dimScale4
    REAL(SP), dimension(dim5), intent(in) :: dimScale5
    REAL(SP), dimension(dim6), intent(in) :: dimScale6
    REAL(SP), dimension(dim1,dim2,dim3,dim4,dim5,dim6), intent(in) :: data6D
    REAL(SP), intent(in) :: x1,x2,x3,x4,x5,x6
    integer, intent(in), OPTIONAL :: node1_in, node2_in, node3_in, node4_in, node5_in, node6_in
    integer, intent(out), OPTIONAL  :: status

    integer :: node1, node2,node3,node4,node5,node6
    REAL(SP), dimension(ndim) :: distance
    REAL(SP), dimension(2**ndim) :: weights, values
    REAL(SP), dimension(6) :: denominator
    integer :: i, j, k, l, m, n
    integer :: npoint

    status = 0 ! set to success

    !adapted by RF van Oss:
    IF ( PRESENT(node1_in) ) THEN
      !nodes are given on input
      node1 = node1_in
      node2 = node2_in
      node3 = node3_in
      node4 = node4_in
      node5 = node5_in
      node6 = node6_in
    ELSE
      node1 = findNode(dimScale1, dim1, x1)
      node2 = findNode(dimScale2, dim2, x2)
      node3 = findNode(dimScale3, dim3, x3)
      node4 = findNode(dimScale4, dim4, x4)
      node5 = findNode(dimScale5, dim5, x5)
      node6 = findNode(dimScale6, dim6, x6)
    ENDIF

    if ( min(node1,node2,node3,node4,node5,node6) <= 0 ) then ! error getting nodes, exit with error
      status = -1
      interpol6D = -huge(interpol6D)
      return
    end if

    denominator(1) = dimscale1(node1+1) - dimscale1(node1)
    denominator(2) = dimscale2(node2+1) - dimscale2(node2)
    denominator(3) = dimscale3(node3+1) - dimscale3(node3)
    denominator(4) = dimscale4(node4+1) - dimscale4(node4)
    denominator(5) = dimscale5(node5+1) - dimscale5(node5)
    denominator(6) = dimscale6(node6+1) - dimscale6(node6)

    npoint = 0
    do i = node1, node1 + 1
      do j = node2, node2 + 1
        do k = node3, node3 + 1
          do l = node4, node4 + 1
            do m = node5, node5 + 1
              do n = node6, node6 + 1

                npoint = npoint + 1

                distance(1) = (x1 - dimscale1(i)) / (denominator(1))

                distance(2) = (x2 - dimscale2(j)) / (denominator(2))

                distance(3) = (x3 - dimscale3(k)) / (denominator(3))

                distance(4) = (x4 - dimscale4(l)) / (denominator(4))

                distance(5) = (x5 - dimscale5(m)) / (denominator(5))

                distance(6) = (x6 - dimscale6(n)) / (denominator(6))

                distance = 1. - abs(distance)

                weights(npoint) = product(distance)

                values(npoint) = data6D(i,j,k,l,m,n)

              end do
            end do
          end do
        end do
      end do
    end do

    ! normalize weights
    weights(1:npoint) =  weights(1:npoint) / sum(weights(1:npoint))

    ! determine output
    interpol6D = 0.
    do i=1, npoint
      interpol6D = interpol6D + weights(i) * values(i)
    end do

    return

  end function interpol6D

  !==============================================================================!
  REAL(SP) function interpol7D(dim1, dim2, dim3 , dim4, dim5, dim6, dim7,&
      dimScale1, dimScale2, dimScale3, dimScale4, dimscale5, dimscale6, dimscale7,&
      data7D, &
      x1, x2, x3, x4, x5, x6, x7, &
      node1_in, node2_in, node3_in, node4_in, node5_in, node6_in, node7_in, &
      status)

    integer, parameter :: ndim=7

    integer, intent(in) :: dim1, dim2, dim3, dim4, dim5, dim6, dim7
    REAL(SP), dimension(dim1), intent(in) :: dimScale1
    REAL(SP), dimension(dim2), intent(in) :: dimScale2
    REAL(SP), dimension(dim3), intent(in) :: dimScale3
    REAL(SP), dimension(dim4), intent(in) :: dimScale4
    REAL(SP), dimension(dim5), intent(in) :: dimScale5
    REAL(SP), dimension(dim6), intent(in) :: dimScale6
    REAL(SP), dimension(dim6), intent(in) :: dimScale7
    REAL(SP), dimension(dim1,dim2,dim3,dim4,dim5,dim6,dim7), intent(in) :: data7D
    REAL(SP), intent(in) :: x1,x2,x3,x4,x5,x6,x7
    integer, intent(in), OPTIONAL :: node1_in, node2_in, node3_in, node4_in, node5_in, node6_in, node7_in
    integer, intent(out), OPTIONAL :: status

    integer :: node1, node2,node3,node4,node5,node6,node7
    REAL(SP), dimension(ndim) :: distance
    REAL(SP), dimension(2**ndim) :: weights, values
    REAL(SP), dimension(7) :: denominator
    integer :: i, j, k, l, m, n, o
    integer :: npoint

    status = 0 ! set to success

    !adapted by RF van Oss:
    IF ( PRESENT(node1_in) ) THEN
      !nodes are given on input
      node1 = node1_in
      node2 = node2_in
      node3 = node3_in
      node4 = node4_in
      node5 = node5_in
      node6 = node6_in
      node7 = node7_in
    ELSE
      node1 = findNode(dimScale1, dim1, x1)
      node2 = findNode(dimScale2, dim2, x2)
      node3 = findNode(dimScale3, dim3, x3)
      node4 = findNode(dimScale4, dim4, x4)
      node5 = findNode(dimScale5, dim5, x5)
      node6 = findNode(dimScale6, dim6, x6)
      node7 = findNode(dimScale7, dim7, x7)
    ENDIF

    if ( min(node1,node2,node3,node4,node5,node6,node7) <= 0 ) then ! error getting nodes, exit with error
      status = -1
      interpol7D = -huge(interpol7D)
      return
    end if

    denominator(1) = dimscale1(node1+1) - dimscale1(node1)
    denominator(2) = dimscale2(node2+1) - dimscale2(node2)
    denominator(3) = dimscale3(node3+1) - dimscale3(node3)
    denominator(4) = dimscale4(node4+1) - dimscale4(node4)
    denominator(5) = dimscale5(node5+1) - dimscale5(node5)
    denominator(6) = dimscale6(node6+1) - dimscale6(node6)
    denominator(7) = dimscale7(node7+1) - dimscale7(node7)

    npoint = 0
    do i = node1, node1 + 1
      do j = node2, node2 + 1
        do k = node3, node3 + 1
          do l = node4, node4 + 1
            do m = node5, node5 + 1
              do n = node6, node6 + 1
                do o = node7, node7 + 1

                  npoint = npoint + 1

                  distance(1) = (x1 - dimscale1(i)) / (denominator(1))

                  distance(2) = (x2 - dimscale2(j)) / (denominator(2))

                  distance(3) = (x3 - dimscale3(k)) / (denominator(3))

                  distance(4) = (x4 - dimscale4(l)) / (denominator(4))

                  distance(5) = (x5 - dimscale5(m)) / (denominator(5))

                  distance(6) = (x6 - dimscale6(n)) / (denominator(6))

                  distance(7) = (x7 - dimscale7(o)) / (denominator(7))

                  distance = 1. - abs(distance)

                  weights(npoint) = product(distance)

                  values(npoint) = data7D(i,j,k,l,m,n,o)

                end do
              end do
            end do
          end do
        end do
      end do
    end do

    ! normalize weights
    weights(1:npoint) =  weights(1:npoint) / sum(weights(1:npoint))

    ! determine output
    interpol7D = 0.
    do i=1, npoint
      interpol7D = interpol7D + weights(i) * values(i)
    end do

    return

  end function interpol7D

  !==============================================================================!

  SUBROUTINE GetNode(dimScale, x, Node, LowerOrUpper)

    ! This subroutine is partly based on (private) function findNode in
    ! this Module .
    ! doesn't use minloc(abs()), but instead starts from the first index and
    !  exits when the node has been found.
    !In case LowerOrUpper = 'Lower',:
    ! GetNode is the index of the largest value in the increasing array dimscale
    ! that is still smaller than x.
    !In case LowerOrUpper = 'Upper':
    ! GetNode is the index of the smallest value in the increasing array dimscale
    ! that is still larger than x.
    !
    !  Roeland van Oss, May 2002

    !INPUT
    REAL(SP), DIMENSION( : ), INTENT(IN) :: dimscale
    REAL(SP), INTENT(IN) :: x
    CHARACTER(*) :: LowerOrUpper

    !OUTPUT
    INTEGER, INTENT(OUT) :: Node

    !LOCAL
    INTEGER :: is, xdim, sdim

    !Find dimension of dimscale
    sdim = SIZE( dimscale)

    ! check if the dimension scale is monotonically increasing as it should
    IF (.NOT. monotonIncrease(dimScale,sdim) ) THEN
      Node = -1
      RETURN
    END IF

    IF ( LowerOrUpper == 'Lower' ) THEN

      is = 0
      DO
        is = is + 1
        IF ( (dimScale(is) > x) .OR. (is > sdim) ) EXIT
      END DO
      Node = is - 1

      !ERROR: x is smaller than the smallest value in dimscale
      IF ( Node == 0    ) Node = -2

      !ERROR: x is larger than the largest value in dimscale
      IF ( Node == sdim ) Node = -3

    ELSE IF ( LowerOrUpper == 'Upper' ) THEN

      is = sdim + 1
      DO
        is = is - 1
        IF ( (dimScale(is) < x) .OR. (is < 1) ) EXIT
      END DO
      Node = is + 1

      !ERROR: x is smaller than the smallest value in dimscale
      IF ( Node == 1        ) Node = -2

      !ERROR: x is larger than the largest value in dimscale
      IF ( Node == sdim + 1 ) Node = -3

    ELSE

    ENDIF

    RETURN

  END SUBROUTINE GetNode

end module OMSAO_lininterpolation_module