!***********************************************************************
!                                                                      *
      SUBROUTINE FRMHYD(INDEX, NSUBS, MODIFY)
!                                                                      *
!   This  subroutine  is  used  to  produce  estimates  of  the wave   *
!   functions from the hydrogenic approximation. The screening cons-   *
!   tant is taken to be 0.4 (Changed, see comments below,XHH)          *
!                                                                      *
!   Call(s) to: [ERWF]: DCBSRW.                                        *
!                                                                      *
!   Written by Farid A Parpia, at Oxford  Last revision: 18 Dec 1992   *
!                                                                      *
!***********************************************************************
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  11:06:21   1/ 2/07
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE DEF_C
      USE LEFT_C
      USE ORB_C, ONLY: E, NP, NAK, NH
      USE WAVE_C, ONLY: PF, QF, PZ, MF
      USE WHFROM_C, ONLY: SOURCE
      USE HYDPAR_C, ONLY: SIGMA
      USE IOUNIT_C
      USE DEFAULT_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dcbsrw_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: NSUBS
      LOGICAL , INTENT(IN) :: MODIFY
      INTEGER , INTENT(IN) :: INDEX(NNNW)
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      !INTEGER, PARAMETER :: NNNP = 590
      INTEGER, PARAMETER :: NNN1 = NNNP + 10
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: J, LOC
      REAL(DOUBLE) :: ZEFF
      LOGICAL :: YES, GETYN
!-----------------------------------------------
!
!
      WRITE (ISTDE, *)
      WRITE (ISTDE, *) '***** Screening parameters ******'
      DO J = 1, NSUBS
         LOC = INDEX(J)
         IF (SET(LOC)) CYCLE

         WRITE (ISTDE, '(I2,A2,F10.2)') NP(LOC), NH(LOC), SIGMA(LOC)
         IF (MODIFY) THEN
            WRITE (ISTDE, *) 'Input new value >'
            READ (5, *) SIGMA(LOC)
         ENDIF

         ZEFF = Z - SIGMA(LOC)

!           ...Calculate radial wavefunctions
         CALL DCBSRW (NP(LOC), NAK(LOC), ZEFF, E(LOC), PZ(LOC), PF(:,LOC), &
            QF(:,LOC), MF(LOC))
         SET(LOC) = .TRUE.
            !SOURCE(LOC) = 'Screened hydrogenic estimate'
         SOURCE(LOC) = 'Hyd'
      END DO
      RETURN
      END SUBROUTINE FRMHYD


      SUBROUTINE ATOMXC( FUNCTL, AUTHOR, IREL,
     .                   NR, MAXR, RMESH, NSPIN, DENS,
     .                   EX, EC, DX, DC, VXC )

C *******************************************************************
C Finds total exchange-correlation energy and potential for a
C spherical electron density distribution.
C This version implements the Local (spin) Density Approximation and
C the Generalized-Gradient-Aproximation with the 'explicit mesh
C functional' method of White & Bird, PRB 50, 4954 (1994).
C Gradients are 'defined' by numerical derivatives, using 2*NN+1 mesh
C   points, where NN is a parameter defined below
C Coded by L.C.Balbas and J.M.Soler. December 1996. Version 0.5.
C ************************* INPUT ***********************************
C CHARACTER*(*) FUNCTL : Functional to be used:
C              'LDA' or 'LSD' => Local (spin) Density Approximation
C                       'GGA' => Generalized Gradient Corrections
C                                Uppercase is optional
C CHARACTER*(*) AUTHOR : Parametrization desired:
C     'CA' or 'PZ' => LSD Perdew & Zunger, PRB 23, 5075 (1981)
C           'PW92' => LSD Perdew & Wang, PRB, 45, 13244 (1992). This is
C                     the local density limit of the next:
C            'PBE' => GGA Perdew, Burke & Ernzerhof, PRL 77, 3865 (1996)
C                     Uppercase is optional
C INTEGER IREL         : Relativistic exchange? (0=>no, 1=>yes)
C INTEGER NR           : Number of radial mesh points
C INTEGER MAXR         : Physical first dimension of RMESH, DENS and VXC
C REAL*8  RMESH(MAXR)  : Radial mesh points
C INTEGER NSPIN        : NSPIN=1 => unpolarized; NSPIN=2 => polarized
C REAL*8  DENS(MAXR,NSPIN) : Total (NSPIN=1) or spin (NSPIN=2) electron
C                            density at mesh points
C ************************* OUTPUT **********************************
C REAL*8  EX              : Total exchange energy
C REAL*8  EC              : Total correlation energy
C REAL*8  DX              : IntegralOf( rho * (eps_x - v_x) )
C REAL*8  DC              : IntegralOf( rho * (eps_c - v_c) )
C REAL*8  VXC(MAXR,NSPIN) : (Spin) exch-corr potential
C ************************ UNITS ************************************
C Distances in atomic units (Bohr).
C Densities in atomic units (electrons/Bohr**3)
C Energy unit depending of parameter EUNIT below
C ********* ROUTINES CALLED *****************************************
C GGAXC, LDAXC
C *******************************************************************

C Next line is nonstandard but may be suppressed
      IMPLICIT NONE

C Argument types and dimensions
      CHARACTER*(*)     FUNCTL, AUTHOR
      INTEGER           IREL, MAXR, NR, NSPIN
      DOUBLE PRECISION  DENS(MAXR,NSPIN), RMESH(MAXR), VXC(MAXR,NSPIN)
      DOUBLE PRECISION  DC, DX, EC, EX

C Fix the order of the numerical derivatives: the number of radial
C points used is 2*NN+1
C MAXAUX must be larger than the number of radial mesh points
      INTEGER NN, MAXAUX
      PARAMETER ( NN     =    5 )
      PARAMETER ( MAXAUX = 2000 )

C Fix energy unit:  EUNIT=1.0 => Hartrees,
C                   EUNIT=0.5 => Rydbergs,
C                   EUNIT=0.03674903 => eV
      DOUBLE PRECISION EUNIT
      PARAMETER ( EUNIT = 0.5D0 )

C DVMIN is added to differential of volume to avoid division by zero
      DOUBLE PRECISION DVMIN
      PARAMETER ( DVMIN = 1.D-12 )

C Local variables and arrays
      LOGICAL
     .  GGA
      INTEGER
     .  IN, IN1, IN2, IR, IS, JN
      DOUBLE PRECISION
     .  AUX(MAXAUX), D(2), DECDD(2), DECDGD(3,2), DEXDD(2), DEXDGD(3,2),
     .  DGDM(-NN:NN), DGIDFJ(-NN:NN), DRDM, DVOL,
     .  EPSC, EPSX, F1, F2, GD(3,2), PI
      EXTERNAL
     .  GGAXC, LDAXC

C Set GGA switch
      IF ( FUNCTL.EQ.'LDA' .OR. FUNCTL.EQ.'lda' .OR.
     .     FUNCTL.EQ.'LSD' .OR. FUNCTL.EQ.'lsd' ) THEN
        GGA = .FALSE.
      ELSEIF ( FUNCTL.EQ.'GGA' .OR. FUNCTL.EQ.'gga') THEN
        GGA = .TRUE.
      ELSE
        WRITE(6,*) 'CELLXC: Unknown functional ', FUNCTL
        STOP
      ENDIF

C Check size of auxiliary array
      IF (GGA .AND. MAXAUX.LT.NR)
     .  STOP 'ATOMXC: Parameter MAXAUX too small'

C Initialize output
      EX = 0
      EC = 0
      DX = 0
      DC = 0
      DO 20 IS = 1,NSPIN
        DO 10 IR = 1,NR
          VXC(IR,IS) = 0
   10   CONTINUE
   20 CONTINUE

C Get number pi
      PI = 4 * ATAN(1.D0)

C Loop on mesh points
      DO 140 IR = 1,NR

C       Find interval of neighbour points to calculate derivatives
        IN1 = MAX(  1, IR-NN ) - IR
        IN2 = MIN( NR, IR+NN ) - IR

C       Find weights of numerical derivation from Lagrange
C       interpolation formula
        DO 50 IN = IN1,IN2
          IF (IN .EQ. 0) THEN
            DGDM(IN) = 0
            DO 30 JN = IN1,IN2
              IF (JN.NE.0) DGDM(IN) = DGDM(IN) + 1.D0 / (0 - JN)
   30       CONTINUE
          ELSE
            F1 = 1
            F2 = 1
            DO 40 JN = IN1,IN2
              IF (JN.NE.IN .AND. JN.NE.0) F1 = F1 * (0  - JN)
              IF (JN.NE.IN)               F2 = F2 * (IN - JN)
   40       CONTINUE
            DGDM(IN) = F1 / F2
          ENDIF
   50   CONTINUE

C       Find dr/dmesh
        DRDM = 0
        DO 60 IN = IN1,IN2
          DRDM = DRDM + RMESH(IR+IN) * DGDM(IN)
   60   CONTINUE

C       Find differential of volume. Use trapezoidal integration rule
        DVOL = 4 * PI * RMESH(IR)**2 * DRDM
C       DVMIN is a small number added to avoid a division by zero
        DVOL = DVOL + DVMIN
        IF (IR.EQ.1 .OR. IR.EQ.NR) DVOL = DVOL / 2
        IF (GGA) AUX(IR) = DVOL

C       Find the weights for the derivative d(gradF(i))/d(F(j)), of
C       the gradient at point i with respect to the value at point j
        IF (GGA) THEN
          DO 80 IN = IN1,IN2
            DGIDFJ(IN) = DGDM(IN) / DRDM
   80     CONTINUE
        ENDIF

C       Find density and gradient of density at this point
        DO 90 IS = 1,NSPIN
          D(IS) = DENS(IR,IS)
   90   CONTINUE
        IF (GGA) THEN
          DO 110 IS = 1,NSPIN
            GD(1,IS) = 0
            GD(2,IS) = 0
            GD(3,IS) = 0
            DO 100 IN = IN1,IN2
              GD(3,IS) = GD(3,IS) + DGIDFJ(IN) * DENS(IR+IN,IS)
  100       CONTINUE
  110     CONTINUE
        ENDIF

C       Find exchange and correlation energy densities and their
C       derivatives with respect to density and density gradient
        IF (GGA) THEN
          CALL GGAXC( AUTHOR, IREL, NSPIN, D, GD,
     .                EPSX, EPSC, DEXDD, DECDD, DEXDGD, DECDGD )
        ELSE
          CALL LDAXC( AUTHOR, IREL, NSPIN, D, EPSX, EPSC, DEXDD, DECDD )
        ENDIF

C       Add contributions to exchange-correlation energy and its
C       derivatives with respect to density at all points
        DO 130 IS = 1,NSPIN
          EX = EX + DVOL * D(IS) * EPSX
          EC = EC + DVOL * D(IS) * EPSC
          DX = DX + DVOL * D(IS) * (EPSX - DEXDD(IS))
          DC = DC + DVOL * D(IS) * (EPSC - DECDD(IS))
          IF (GGA) THEN
            VXC(IR,IS) = VXC(IR,IS) + DVOL * ( DEXDD(IS) + DECDD(IS) )
            DO 120 IN = IN1,IN2
              DX= DX - DVOL * DENS(IR+IN,IS) * DEXDGD(3,IS) * DGIDFJ(IN)
              DC= DC - DVOL * DENS(IR+IN,IS) * DECDGD(3,IS) * DGIDFJ(IN)
              VXC(IR+IN,IS) = VXC(IR+IN,IS) + DVOL *
     .               (DEXDGD(3,IS) + DECDGD(3,IS)) * DGIDFJ(IN)
  120       CONTINUE
          ELSE
            VXC(IR,IS) = DEXDD(IS) + DECDD(IS)
          ENDIF
  130   CONTINUE

  140 CONTINUE

C Divide by volume element to obtain the potential (per electron)
      IF (GGA) THEN
        DO 160 IS = 1,NSPIN
          DO 150 IR = 1,NR
            DVOL = AUX(IR)
            VXC(IR,IS) = VXC(IR,IS) / DVOL
  150     CONTINUE
  160   CONTINUE
      ENDIF

C Divide by energy unit
      EX = EX / EUNIT
      EC = EC / EUNIT
      DX = DX / EUNIT
      DC = DC / EUNIT
      DO 180 IS = 1,NSPIN
        DO 170 IR = 1,NR
          VXC(IR,IS) = VXC(IR,IS) / EUNIT
  170   CONTINUE
  180 CONTINUE

      END


!############################################################
!############################################################
!############################################################
!############################################################
subroutine boundana(x,u,dx,ibound,ncell)
  use amr_parameters, ONLY: dp,ndim,nvector,Mvir,overdensity,boxlen
  use hydro_parameters, ONLY: nvar,boundary_var,gamma
  implicit none
  integer ::ibound                        ! Index of boundary region
  integer ::ncell                         ! Number of active cells
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector,1:nvar)::u ! Conservative variables
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine generates boundary conditions for RAMSES.
  ! Positions are in user units:
  ! x(i,1:3) are in [0,boxlen]**ndim.
  ! U is the conservative variable vector. Conventions are here:
  ! U(i,1): d, U(i,2:ndim+1): d.u,d.v,d.w and U(i,ndim+2): E.
  ! U is in user units.
  ! ibound is the index of the boundary region defined in the namelist.
  !================================================================
  integer::ivar,i
  real(dp) :: pi,Mvirphu,rvir,cnfw,eta0,gammaKS,d_init,p_init
  real(dp) :: rx,ry,rz,xmass,ymass,zmass,rr

  do ivar=1,nvar
     do i=1,ncell
        u(i,ivar)=boundary_var(ibound,ivar)
     end do
  end do

  ! Add here, if you wish, some user-defined boudary conditions
  ! ........
  pi=3.14
  Mvirphu = Mvir*1.99d33
  rvir = (3./4./pi*Mvirphu/(overdensity*1.89d-29*0.65**2))**0.333
  cnfw = 6./(Mvir/1.d14)**.2
  eta0 = 0.00676*(cnfw-6.5)**2+0.206*(cnfw-6.5)+2.48
  gammaKS = 1.15+0.01*(cnfw-6.5)
  d_init = 0.1*overdensity*1.89d-29*.65**2&
  &        *cnfw**2/3./(1.+cnfw)**2/(log(1.+cnfw)-cnfw/(1.+cnfw))&
  &        /(1.-3./eta0*(gammaKS-1.0d0)/gammaKS*cnfw/(log(1.+cnfw)&
  &        -cnfw/(1.+cnfw))&
  &        *(1.-log(1.+cnfw)/cnfw))**(1./(gammaKS-1.0d0))
  p_init = 6.672d-8/3.*d_init*Mvirphu/rvir*eta0
  xmass=0.5*boxlen
  ymass=0.5*boxlen
  zmass=0.5*boxlen
  do i=1,ncell
     rx=0.0d0; ry=0.0d0; rz=0.0d0
     rx=x(i,1)-xmass
#if NDIM>1
     ry=x(i,2)-ymass
#endif
#if NDIM>2
     rz=x(i,3)-zmass
#endif
     rr=sqrt(rx**2+ry**2+rz**2)
     U(i,1)=d_init&
     &*(1.-3./eta0*(gammaKS-1.0d0)/gammaKS*cnfw/(log(1.+cnfw)&
     &-cnfw/(1.+cnfw))&
     &*(1.-log(1.+cnfw*rr/rvir)/(cnfw*rr/rvir)))**(1./(gammaKS-1.0d0))
     U(i,2)=0.0d0
     U(i,3)=0.0d0
     U(i,4)=0.0d0
     U(i,5)=p_init/d_init/(gamma-1.0d0)&
     &*(1.-3./eta0*(gammaKS-1.)/gammaKS*cnfw&
     &/(log(1.+cnfw)-cnfw/(1.+cnfw))&
     &*(1.-log(1.+cnfw*rr/rvir)/(cnfw*rr/rvir)))*U(i,1)
  end do

end subroutine boundana


      subroutine diff (v, dx, n, vm)
      implicit double precision (a-h,o-z)
      complex*16 v(n), vm(n)
      vm(1)=((6.0*v(2)+6.66666666667*v(4)+1.2*v(6))-(2.45*v(1)+7.
     1 5*v(3)+3.75*v(5)+.166666666667*v(7)))/dx
      vm(2)=((6.0*v(3)+6.66666666667*v(5)+1.2*v(7))-(2.45*v(2)+7.
     1 5*v(4)+3.75*v(6)+.166666666667*v(8)))/dx
      nm2=n-2
      do 10 i=3,nm2
   10 vm(i)=((v(i-2)+8.0*v(i+1))-(8.0*v(i-1)+v(i+2)))/12.0/dx
      vm(n-1)=(v(n)-v(n-2))/(2.0*dx)
      vm(n)=(v(n-2)*.5-2.0*v(n-1)+1.5*v(n))/dx
      return
      end


module mg_zr_zw

  implicit none

  interface setup_zr_zw
     module procedure           &
          setup_zr_zw_seamount, &
          setup_zr_zw_croco
  end interface setup_zr_zw

contains

  !-------------------------------------------------------------------------
  subroutine setup_zr_zw_seamount(h, zr, zw)

    integer(kind=4),parameter :: ip=4,rp=8
    real(kind=rp), dimension(:,:)  , pointer, intent(in)  :: h
    real(kind=rp), dimension(:,:,:), pointer, intent(out) :: zr
    real(kind=rp), dimension(:,:,:), pointer, intent(out) :: zw

    integer(kind=ip):: nx,ny,nz,nh

    integer(kind=ip):: i,j,k

    nz = size(zr,dim=1)
    nh = abs(lbound(zr,dim=2)-1) ! Assume that "one" is the first indice !
    !                            !  1 -> nh = 0  <= abs( 1-1) = 0
    !                            !  0 -> nh = 1  <= abs( 0-1) = 1
    !                            ! -1 -> nh = 2  <= abs(-1-1) = 2
    ny = size(zr,dim=2) - 2*nh
    nx = size(zr,dim=3) - 2*nh

    do i = 1-nh,nx+nh
       do j = 1-nh,ny+nh
          do k = 1,nz
             zr(k,j,i) = (real(k,kind=rp)-0.5_rp)*h(j,i)/real(nz,kind=rp) - h(j,i)
             zw(k,j,i) = (real(k,kind=rp)-1.0_rp)*h(j,i)/real(nz,kind=rp) - h(j,i)
          enddo
          zw(nz+1,j,i) = 0.0_rp
       enddo
    enddo

  end subroutine setup_zr_zw_seamount

  !-------------------------------------------------------------------------
  subroutine setup_zr_zw_croco(hlim,theta_b,theta_s,zeta,h,zr,zw,coord_type)

    ! compute zr and zw from zeta(j,i) and h(j,i)

    integer(kind=4),parameter :: ip=4,rp=8

    real(kind=rp), intent(in) :: hlim
    real(kind=rp), intent(in) :: theta_b
    real(kind=rp), intent(in) :: theta_s
    real(kind=rp), dimension(:,:)  , pointer, intent(in)  :: zeta, h
    real(kind=rp), dimension(:,:,:), pointer, intent(out) :: zr, zw

    character(len=*), optional, intent(in) :: coord_type

    character(len=16) :: coord

    real(kind=rp), parameter :: nul  = 0._rp
    real(kind=rp), parameter :: one  = 1._rp
    real(kind=rp), parameter :: hlf  = 0.5_rp

    integer(kind=ip):: nx,ny,nz,nh

    integer(kind=ip):: i,j,k

    real(kind=rp) :: cff,cff1,cff2
    real(kind=rp) :: hinv
    real(kind=rp) :: sc_w,sc_r,cff_w,cff_r
    real(kind=rp) :: z_w0,z_r0
    real(kind=rp) :: cs_r,cs_w
    real(kind=rp) :: csrf, cswf, hc

    if (present(coord_type)) then
       coord = trim(coord_type)
    else
       coord = 'new_s_coord'
    endif

    nz = size(zr,dim=1)
    nh = abs(lbound(zr,dim=2)-1) ! Assume that "one" is the first indice !
    !                            !  1 -> nh = 0  <= abs( 1-1) = 0
    !                            !  0 -> nh = 1  <= abs( 0-1) = 1
    !                            ! -1 -> nh = 2  <= abs(-1-1) = 2
    ny = size(zr,dim=2) - 2*nh
    nx = size(zr,dim=3) - 2*nh

    nh = 1

    ! vertical coordinate

    !---------------------!
    !- New s-coordinates -!
    !---------------------!
    if (trim(coord) == 'new_s_coord') then

       do i = 1-nh,nx+nh

          do j = 1-nh,ny+nh

             cff=one/real(nz,kind=rp)

             hinv = one / (h(j,i)+hlim)

             do k = 1,nz

                sc_r = cff*(real(k-nz,kind=rp)-hlf)

                if (theta_s > nul) then
                   csrf=(one-cosh(theta_s*sc_r))/(cosh(theta_s)-one)
                else
                   csrf=-sc_r**2
                endif

                if (theta_b > nul) then
                   cs_r=(exp(theta_b*csrf)-one)/(one-exp(-theta_b))
                else
                   cs_r=csrf
                endif

                sc_w = cff*real(k-1-nz,kind=rp)

                if (theta_s > nul) then
                   cswf=(one-cosh(theta_s*sc_w))/(cosh(theta_s)-one)
                else
                   cswf=-sc_w**2
                endif

                if (theta_b > nul) then
                   cs_w=(exp(theta_b*cswf)-one)/(one-exp(-theta_b))
                else
                   cs_w=cswf
                endif

                cff_w = hlim * sc_w
                cff_r = hlim * sc_r

                z_w0 = cff_w + cs_w*h(j,i)
                z_r0 = cff_r + cs_r*h(j,i)

                zw(k,j,i) = z_w0*h(j,i)*hinv + zeta(j,i)*(1.+z_w0*hinv)
                zr(k,j,i) = z_r0*h(j,i)*hinv + zeta(j,i)*(1.+z_r0*hinv)

             enddo

             k = nz+1

             sc_w = cff*real(k-1-nz,kind=rp)

             if (theta_s > nul) then
                cswf=(one-cosh(theta_s*sc_w))/(cosh(theta_s)-one)
             else
                cswf=-sc_w**2
             endif

             if (theta_b > nul) then
                cs_w=(exp(theta_b*cswf)-one)/(one-exp(-theta_b))
             else
                cs_w=cswf
             endif

             cff_w = hlim * sc_w
             z_w0 = cff_w + cs_w*h(j,i)
             zw(k,j,i) = z_w0*h(j,i)*hinv + zeta(j,i)*(1.+z_w0*hinv)

          enddo ! j
       enddo ! i

       !---------------------!
       !- Sigma coordinates -!
       !---------------------!
    else

       cff  = one/real(nz, kind=rp)
       cff1 = one/sinh(theta_s)
       cff2 = hlf/tanh(hlf*theta_s)

       do i = 1-nh,nx+nh
          do j = 1-nh,ny+nh

             do k = 1,nz

                sc_w = cff*real(k-1-nz,kind=rp)
                sc_r = cff*(real(k-nz,kind=rp)-hlf)

                cs_r = (1.-theta_b)*cff1*sinh(theta_s*sc_r) &
                     +theta_b*(cff2*tanh(theta_s*(sc_r+hlf))-hlf)

                cs_w = (1.-theta_b)*cff1*sinh(theta_s*sc_w) &
                     +theta_b*(cff2*tanh(theta_s*(sc_w+hlf))-hlf)

                cff_w = hc * sc_w
                cff_r = hc * sc_r

                z_w0 = cff_w + cs_w*h(j,i)
                z_r0 = cff_r + cs_r*h(j,i)

                hinv = one / (h(j,i)+hc)

                zw(k,j,i) = z_w0 * (h(j,i)*hinv)
                zr(k,j,i) = z_r0 * (h(j,i)*hinv)

             enddo ! k

             zw(nz+1,j,i) = nul

          enddo ! j
       enddo ! i

    endif

  end subroutine setup_zr_zw_croco

end module mg_zr_zw


      function epcorr(chd,gradc,radius,ivepc,alpgga,rspmax)
c
c   purpose: compute the positron correlation potential for a given
c            electron charge density
c
c   method:
c            compute potential based on parameters and functional form.
c            if alpgga is not zero, make the gga correction based on
c            the gradient of the charge density.
c
c   calls:  fns : rs, intrinsic functions datan, exp, sqrt, log
c
c written:  philip sterne, sterne1@llnl.gov
c date:     May 04, 1998
c changes:
c     7/13/98 : added rspmax to control maximum rs value in computing
c               ep-corr potentials.                  sterne1@llnl.gov
c comments:
c  ivepc    positron correlation
c
c    0     Sterne-Kaiser        PRB 43, 13892 (1991)
c    1     Boronski-Nieminen    PRB 34,  3820 (1986)
c    2     IPM                  No interaction - Independent Particle Model
c
c    Sterne-Kaiser and Boronski-Nieminen are both fit to rpa,
c    arponnen and pajanne (ann phys 121 343), and low density limits.
c
      implicit none
c
c     input variables
c
      real*8 chd        ! charge density - either n(r) or 4*pi*r**2*n(r)
      real*8 gradc      ! magnitude of the gradient of the charge density
                        !  - either |del(n(r))| or 4*pi*r**2*|del(n(r))|
      real*8 radius     ! if zero, chd is just n(r), else radius r for chd
      integer ivepc     ! choice of electron-positron correlation potential
      real*8 alpgga     ! alpha for gga correction - zero means no gga
      real*8  rspmax    ! maximum rs in positron-electron correlation.
                        ! for larger rs values, epcorr(rspmax) is used
c
c     output variables
c
      real*8 epcorr     ! calculated electron-positron correlation
c
c     internal variables
c
      real*8  skc(5)    ! parameters for Sterne-Kaiser fit
      real*8 bnc(4,4)   ! parameters for Boronski-Nieminen fit
      real*8 bnrs(4)    ! rs-cutoffs for Boronski-Nieminen fit
      real*8 rs         ! function - calculate rs from charge density
      real*8 rs1        ! rs value corresponding to input chd
      real*8 rsd        ! shifted rs value - used in functional
      real*8 fwvec      ! fermi wavevector
      real*8 qtfsq      ! (Thomas-Fermi screening length)**2
      real*8 epsgga     ! contribution to gga correlation function
      real*8 expgga     ! contribution to gga correlation function
      real*8 pi         ! well-known approximation to 22/7
c
      data skc /-1.56d0, 0.7207d0, 4.092d0, 51.96d0, 0.1324d0/
c
      data bnc / -1.56d0,     0.051d0,   -0.081d0,   1.14d0,
     *           -0.92305d0, -0.05459d0,  0.d0,      0.d0,
     *          -13.15111d0,  2.5d0,      2.8655d0, -0.6298d0,
     *       -10250.5786d0,  44.50466d0, -0.524d0,   0.d0/
c
      data bnrs/0.302d0, 0.56d0, 8.0d0, 200.d0/
c
c     convert from charge density to r_s
c
      rs1 = rs(chd,radius,rspmax)
c ---------------------------------------------------------------------------
c       electron-positron correlation potential functional
c ---------------------------------------------------------------------------
c
      if (ivepc.eq.0) then
c
c          sterne-kaiser fit
c
         if (rs1.gt.bnrs(4)) then
            epcorr=bnc(3,4)
         else
            epcorr=skc(1)/sqrt(atan(rs1))+skc(2)+
     *             skc(5)*exp(-((rs1-skc(3))**2)/skc(4))
         endif
c
      else if (ivepc.eq.1) then
c
c          boronski-neimenen fit
c
         if (rs1.gt.bnrs(4)) then
            epcorr=bnc(3,4)
         else if (rs1.gt.bnrs(3)) then
            epcorr=bnc(1,4)/(rs1**6)+bnc(2,4)/(rs1**3)+bnc(3,4)
         else if (rs1.gt.bnrs(2)) then
            rsd=rs1+bnc(2,3)
            epcorr=bnc(1,3)/rsd/rsd+bnc(3,3)/rsd+bnc(4,3)
         else if (rs1.gt.bnrs(1)) then
            epcorr=bnc(1,2)+bnc(2,2)/rs1/rs1
         else
            epcorr=bnc(1,1)/sqrt(rs1)+
     *           (bnc(2,1)*log(rs1)+bnc(3,1))*log(rs1)+bnc(4,1)
         endif
c
      else if(ivepc.eq.2) then
c
c     no electron-positron correlation - IPM
c
         epcorr=0.d0
c
      else
         write(*,*) 'error in epcorr: ivepc = ',ivepc,
     *                 '     unknown option - stopping'
         stop 'ivepc in epcorr'
      endif
c
c   gga correction
c
      if(alpgga.gt.0.d0) then
c
c   find local fermi wavevector fwvec and use it to calculate
c   the square of the thomas-fermi screening length, qtfsq
c
         pi = 4.d0*datan(1.d0)
         fwvec = ((9.d0*pi/4.d0)**(1.d0/3.d0))/rs1
         qtfsq = 4.d0*fwvec/pi
c
c   compute the lda gradient correction term epsgga
c   and the exponential factor expgga = exp(-alpgga*epsgga)
c
         if(rs1.lt.rspmax) then
            epsgga = (gradc/chd)**2/qtfsq
            expgga = dexp(-alpgga*epsgga)
         else
            epsgga = 0.d0
            expgga = 1.d0
         endif
c
c   correct epcorr with gga term
c
         epcorr = epcorr*expgga**(1.d0/3.d0)
      endif
c
      return
      end


      SUBROUTINE modular_curve (n, u, v, tx, ty, tz, c)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE stel_constants
      USE modular_coils
      USE Vwire
      USE coils
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: k, n, ncl
      REAL(rprec) :: tx, ty, tz
      REAL(rprec) :: ck, sk, u, v,
     1   ph0, ph1, ph2, r0, r1, r2, z0, z1, z2,
     2   x0, x1, x2, y0, y1, y2, s1, c
      REAL(rprec) :: th0, th1
      REAL(rprec) :: fth0, fth1, fth2
!-----------------------------------------------

!     compute theta and derivative wrt u. Note: u=s in Eq. 2 of Strickler, et al

      ncl = n
      th0 = twopi*u
      th1 = twopi

!     compute phi and derivatives wrt u

      IF (nf_rho .GT. 0) THEN
!     Case with possible windbacks - call theta_f to modify argument th0
!     put theta and derivatives in temporary variables fth0, fth1, fth2 so
!     the winding law calculation will not interfere with the winding
!     surface evaluation below
         fth0 = th0
         CALL theta_f (ncl, fth0, fth1, fth2)
         ph0 = phi_full(ncl)
         ph1 = 0
         ph2 = 0
         DO k = 0,nf_phi
            ck = COS(k*fth0)
            sk = SIN(k*fth0)
            ph0 = ph0 +  modular(ncl)%phic(k)*ck
     1                +  modular(ncl)%phis(k)*sk
            ph1 = ph1 + (modular(ncl)%phis(k)*ck
     1                -  modular(ncl)%phic(k)*sk)*k
            ph2 = ph2 + (modular(ncl)%phis(k)*sk
     1                +  modular(ncl)%phic(k)*ck)*k**2
         END DO
!     note the order of the next two lines is important
         ph2 = twopi**2*(ph2*fth1**2 + ph1*fth2)
         ph1 = twopi*fth1*ph1
      ELSE
!     Case without windbacks
         ph0 = phi_full(ncl)
         ph1 = 0
         ph2 = 0
         DO k = 0,nf_phi
            ck = COS(k*th0)
            sk = SIN(k*th0)
            ph0 = ph0 +  modular(ncl)%phic(k)*ck
     1                +  modular(ncl)%phis(k)*sk
            ph1 = ph1 + (modular(ncl)%phis(k)*ck
     1                -  modular(ncl)%phic(k)*sk)*k
            ph2 = ph2 + (modular(ncl)%phis(k)*sk
     1                +  modular(ncl)%phic(k)*ck)*k**2
         END DO
         ph1 = th1*ph1
         ph2 = -th1**2*ph2
      END IF

!     compute R, Z and derivatives wrt u

      r0 = 0
      r1 = 0
      r2 = 0
      z0 = 0
      z1 = 0
      z2 = 0
      DO k = 1, numsurf
         ck = COS(m_num(k)*th0 + nfper*n_num(k)*ph0)
         sk = SIN(m_num(k)*th0 + nfper*n_num(k)*ph0)
!     R ...
         r0 = r0 + rmn_sf(k)*ck
         r1 = r1 - rmn_sf(k)*(m_num(k)*th1 + nfper*n_num(k)*ph1)*sk
         r2 = r2 - rmn_sf(k)*(nfper*n_num(k)*ph2*sk
     1      + (m_num(k)*th1 + nfper*n_num(k)*ph1)**2*ck)
!     Z ...
         z0 = z0 + zmn_sf(k)*sk
         z1 = z1 + zmn_sf(k)*(m_num(k)*th1 + nfper*n_num(k)*ph1)*ck
         z2 = z2 + zmn_sf(k)*(nfper*n_num(k)*ph2*ck
     1      - (m_num(k)*th1 + nfper*n_num(k)*ph1)**2*sk)
      END DO

!     compute X and derivatives wrt u

      x0 = r0*COS(ph0)
      x1 = r1*COS(ph0) - r0*ph1*SIN(ph0)
      x2 = r2*COS(ph0) - r1*ph1*SIN(ph0)
     1   - (r0*ph1**2*COS(ph0) + (r0*ph2 + r1*ph1)*SIN(ph0))

!     compute Y and derivatives wrt u

      y0 = r0*SIN(ph0)
      y1 = r1*SIN(ph0) + r0*ph1*COS(ph0)
      y2 = r2*SIN(ph0) + r1*ph1*COS(ph0)
     1   + (-r0*ph1**2*SIN(ph0) + (r0*ph2 + r1*ph1)*COS(ph0))

!     compute ds/du

      s1 = SQRT (x1*x1 + y1*y1 + z1*z1)

!     TANgent vector dx/ds, dy/ds, dz/ds

      tx = x1/s1
      ty = y1/s1
      tz = z1/s1

!     compute curvature

      c = SQRT ((y1*z2 - y2*z1)**2
     1        + (z1*x2 - z2*x1)**2
     2        + (x1*y2 - x2*y1)**2)/s1**3

!     RETURN toroidal v
      v = nfper*ph0/twopi

      END SUBROUTINE modular_curve


C     LAST UPDATE 06/06/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE TBKSB(W,V,N,NP,B,X)
      IMPLICIT NONE
C
C Purpose: Solves A.X = B for a vector X, where A is specified by the
C          arrays W,V as returned by TRED2,TQLI. N is the logical
C          dimension of A (originally square and symmetric).
C          NP are the physical dimensions of A. B is the input right
C          hand side. X is the output solution vector. No input
C          quantities are destroyed so the routine may be called
C          sequentially with different B's.
C
      INTEGER N,NP
      DOUBLE PRECISION V(NP,NP),W(NP),B(NP),X(NP)
C
C Calls   0:
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      DOUBLE PRECISION S,WTMP,VTMP,XTMP,BTMP
      INTEGER I,J,K
C
C---------------------------------------------------------------------
C
C========Initialize X
C
      DO 10 I=1,N
         X(I) = 0.0D0
 10   CONTINUE
C
C========Loop over eigenvalues
C
      DO 50 K=1,N
         IF(W(K).NE.0.0D0)THEN
            WTMP = 1.0D0/W(K)
C
C========Accumulate diagonal elements
C
            DO 20 I=1,N
               X(I) = X(I) + V(I,K)*WTMP*V(I,K)*B(I)
 20         CONTINUE
C
C========Accumulate off-diagonal elements using symmetry
C
            DO 40 I=1,N-1
               XTMP = X(I)
               BTMP = B(I)
               VTMP = V(I,K)
               DO 30 J=I+1,N
                  S = VTMP*WTMP*V(J,K)
                  XTMP = XTMP + S*B(J)
                  X(J) = X(J) + S*BTMP
 30            CONTINUE
               X(I) = XTMP
 40         CONTINUE
         ENDIF
 50   CONTINUE
      RETURN
      END


! Simplified calling sequence for lapack LU decomposition ZGETRF
! === Parameters ===
! A - NxN matrix to be factored (factorization will overwrite A)
! === Output ===
! P - permutation vector Nx1
subroutine ZLU(A,P)
    implicit none
    complex(kind=8), intent(inout)  :: A(:,:)
    integer,         intent(out)    :: P(size(A,1))
    integer :: info,n
    n = size(A,1)
    call ZGETRF(n,n,A,n,P,INFO) !http://www.netlib.no/netlib/lapack/complex16/zgetrf.f
end subroutine ZLU


!*==ssptrd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SSPTRD
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SSPTRD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, N
!       ..
!       .. Array Arguments ..
!       REAL               AP( * ), D( * ), E( * ), TAU( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SSPTRD reduces a real symmetric matrix A stored in packed form to
!> symmetric tridiagonal form T by an orthogonal similarity
!> transformation: Q**T * A * Q = T.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] AP
!> \verbatim
!>          AP is REAL array, dimension (N*(N+1)/2)
!>          On entry, the upper or lower triangle of the symmetric matrix
!>          A, packed columnwise in a linear array.  The j-th column of A
!>          is stored in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!>          On exit, if UPLO = 'U', the diagonal and first superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          tridiagonal matrix T, and the elements above the first
!>          superdiagonal, with the array TAU, represent the orthogonal
!>          matrix Q as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and first subdiagonal of A are over-
!>          written by the corresponding elements of the tridiagonal
!>          matrix T, and the elements below the first subdiagonal, with
!>          the array TAU, represent the orthogonal matrix Q as a product
!>          of elementary reflectors. See Further Details.
!> \endverbatim
!>
!> \param[out] D
!> \verbatim
!>          D is REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T:
!>          D(i) = A(i,i).
!> \endverbatim
!>
!> \param[out] E
!> \verbatim
!>          E is REAL array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is REAL array, dimension (N-1)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n-1) . . . H(2) H(1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
!>  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(n-1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
!>  overwriting A(i+2:n,i), and tau is stored in TAU(i).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SSPTRD(Uplo,N,Ap,D,E,Tau,Info)
      IMPLICIT NONE
!*--SSPTRD154
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , N
!     ..
!     .. Array Arguments ..
      REAL Ap(*) , D(*) , E(*) , Tau(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO , HALF
      PARAMETER (ONE=1.0,ZERO=0.0,HALF=1.0/2.0)
!     ..
!     .. Local Scalars ..
      LOGICAL upper
      INTEGER i , i1 , i1i1 , ii
      REAL alpha , taui
!     ..
!     .. External Subroutines ..
      EXTERNAL SAXPY , SLARFG , SSPMV , SSPR2 , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      REAL SDOT
      EXTERNAL LSAME , SDOT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      Info = 0
      upper = LSAME(Uplo,'U')
      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SSPTRD',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N<=0 ) RETURN
!
      IF ( upper ) THEN
!
!        Reduce the upper triangle of A.
!        I1 is the index in AP of A(1,I+1).
!
         i1 = N*(N-1)/2 + 1
         DO i = N - 1 , 1 , -1
!
!           Generate elementary reflector H(i) = I - tau * v * v**T
!           to annihilate A(1:i-1,i+1)
!
            CALL SLARFG(i,Ap(i1+i-1),Ap(i1),1,taui)
            E(i) = Ap(i1+i-1)
!
            IF ( taui/=ZERO ) THEN
!
!              Apply H(i) from both sides to A(1:i,1:i)
!
               Ap(i1+i-1) = ONE
!
!              Compute  y := tau * A * v  storing y in TAU(1:i)
!
               CALL SSPMV(Uplo,i,taui,Ap,Ap(i1),1,ZERO,Tau,1)
!
!              Compute  w := y - 1/2 * tau * (y**T *v) * v
!
               alpha = -HALF*taui*SDOT(i,Tau,1,Ap(i1),1)
               CALL SAXPY(i,alpha,Ap(i1),1,Tau,1)
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w**T - w * v**T
!
               CALL SSPR2(Uplo,i,-ONE,Ap(i1),1,Tau,1,Ap)
!
               Ap(i1+i-1) = E(i)
            ENDIF
            D(i+1) = Ap(i1+i)
            Tau(i) = taui
            i1 = i1 - i
         ENDDO
         D(1) = Ap(1)
      ELSE
!
!        Reduce the lower triangle of A. II is the index in AP of
!        A(i,i) and I1I1 is the index of A(i+1,i+1).
!
         ii = 1
         DO i = 1 , N - 1
            i1i1 = ii + N - i + 1
!
!           Generate elementary reflector H(i) = I - tau * v * v**T
!           to annihilate A(i+2:n,i)
!
            CALL SLARFG(N-i,Ap(ii+1),Ap(ii+2),1,taui)
            E(i) = Ap(ii+1)
!
            IF ( taui/=ZERO ) THEN
!
!              Apply H(i) from both sides to A(i+1:n,i+1:n)
!
               Ap(ii+1) = ONE
!
!              Compute  y := tau * A * v  storing y in TAU(i:n-1)
!
               CALL SSPMV(Uplo,N-i,taui,Ap(i1i1),Ap(ii+1),1,ZERO,Tau(i),&
     &                    1)
!
!              Compute  w := y - 1/2 * tau * (y**T *v) * v
!
               alpha = -HALF*taui*SDOT(N-i,Tau(i),1,Ap(ii+1),1)
               CALL SAXPY(N-i,alpha,Ap(ii+1),1,Tau(i),1)
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w**T - w * v**T
!
               CALL SSPR2(Uplo,N-i,-ONE,Ap(ii+1),1,Tau(i),1,Ap(i1i1))
!
               Ap(ii+1) = E(i)
            ENDIF
            D(i) = Ap(ii)
            Tau(i) = taui
            ii = i1i1
         ENDDO
         D(N) = Ap(ii)
      ENDIF
!
!
!     End of SSPTRD
!
      END SUBROUTINE SSPTRD


      implicit real *8 (a-h,o-z)
      real *8, allocatable :: sources(:,:),targ(:,:)
      complex *16, allocatable :: charges(:),dipstr(:)
      complex *16, allocatable :: pot(:),grad(:),hess(:)
      real *8, allocatable :: potr(:),pottargr(:)
      complex *16, allocatable :: pottarg(:),gradtarg(:),hesstarg(:)

      complex *16, allocatable :: potex(:),gradex(:),hessex(:)
      real *8, allocatable :: potexr(:),pottargexr(:)
      complex *16, allocatable :: pottargex(:),gradtargex(:),
     1                             hesstargex(:)

      real *8 expc(100),texps(100),scj(100)

      integer ipass(27)

      complex *16 ima
      data ima/(0.0d0,1.0d0)/

      call prini(6,13)

      ntests=9
      do i = 1,ntests
         ipass(i) = 0
      enddo

      done = 1
      pi = atan(done)*4

      nsrc = 10000
      ntarg = nsrc

      allocate(sources(2,nsrc),charges(nsrc),dipstr(nsrc))
      allocate(targ(2,ntarg))
      allocate(pot(nsrc),grad(nsrc),hess(nsrc),potr(nsrc))
      allocate(pottarg(ntarg),gradtarg(ntarg),hesstarg(ntarg))
      allocate(pottargr(ntarg))

      do i=1,nsrc

         sources(1,i) = hkrand(0)
         sources(2,i) = hkrand(0)

         charges(i) = hkrand(0)

         dipstr(i) = hkrand(0) + ima*hkrand(0)

      enddo

      do i=1,ntarg
         targ(1,i) = hkrand(0)
         targ(2,i) = hkrand(0)
      enddo

      nts = min(20,nsrc)
      ntt = min(20,ntarg)

      allocate(potex(nts),gradex(nts),hessex(nts),potexr(nts))
      allocate(pottargex(ntt),gradtargex(ntt),hesstargex(ntt))
      allocate(pottargexr(ntt))

c
cc      test low frequency mode
c
      eps = 0.5d-6
c
c
cc      now test source to source  + target, charge
c       with potentials
c
      write(6,*) 'testing stost, charge, potentials'

      call cfmm2d_st_c_p(eps,nsrc,sources,charges,
     1        pot,ntarg,targ,pottarg)

c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(pottargex,2*ntt)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo
      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      errgs = 0
      errgt = 0

      errhs = 0
      errht = 0
      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(1) = 1

c
c
cc      now test source to source  + target, charge
c       with gradients
c
      write(6,*) 'testing stost, charge, gradients'

      call cfmm2d_st_c_g(eps,nsrc,sources,charges,
     1        pot,grad,ntarg,targ,pottarg,gradtarg)
c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(gradex,2*nts)
      call dzero(pottargex,2*ntt)
      call dzero(gradtargex,2*ntt)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo
      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      call derr(gradex,grad,2*nts,errgs)
      call derr(gradtargex,gradtarg,2*ntt,errgt)

      errhs = 0
      errht = 0
      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(2) = 1

c
c
cc      now test source to source  + target, charge
c       with hessians
c

      write(6,*) 'testing stost, charge, hessians'
      call cfmm2d_st_c_h(eps,nsrc,sources,charges,
     1        pot,grad,hess,ntarg,targ,pottarg,gradtarg,
     2        hesstarg)
c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(gradex,2*nts)
      call dzero(hessex,2*nts)
      call dzero(pottargex,2*ntt)
      call dzero(gradtargex,2*ntt)
      call dzero(hesstargex,2*ntt)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 3
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo

      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      call derr(gradex,grad,2*nts,errgs)
      call derr(hessex,hess,2*nts,errhs)
      call derr(gradtargex,gradtarg,2*ntt,errgt)
      call derr(hesstargex,hesstarg,2*nts,errht)

      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(3) = 1

c
c
c
c
cc      now test source to source  + target, dipole
c       with potentials
c
      write(6,*) 'testing stost, dipole, potentials'

      call cfmm2d_st_d_p(eps,nsrc,sources,dipstr,
     1        pot,ntarg,targ,pottarg)

c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(pottargex,2*ntt)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo
      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      errgs = 0
      errgt = 0

      errhs = 0
      errht = 0
      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(4) = 1

c
c
cc      now test source to source  + target, dipole
c       with gradients
c
      write(6,*) 'testing stost, dipole, gradients'

      call cfmm2d_st_d_g(eps,nsrc,sources,dipstr,
     1        pot,grad,ntarg,targ,pottarg,gradtarg)
c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(gradex,2*nts)
      call dzero(pottargex,2*ntt)
      call dzero(gradtargex,2*ntt)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo
      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      call derr(gradex,grad,2*nts,errgs)
      call derr(gradtargex,gradtarg,2*ntt,errgt)

      errhs = 0
      errht = 0
      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(5) = 1

c
c
cc      now test source to source  + target, dipole
c       with hessians
c

      write(6,*) 'testing stost, dipole, hessians'
      call cfmm2d_st_d_h(eps,nsrc,sources,dipstr,
     1        pot,grad,hess,ntarg,targ,pottarg,gradtarg,
     2        hesstarg)
c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(gradex,2*nts)
      call dzero(hessex,2*nts)
      call dzero(pottargex,2*ntt)
      call dzero(gradtargex,2*ntt)
      call dzero(hesstargex,2*ntt)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 3
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo
      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      call derr(gradex,grad,2*nts,errgs)
      call derr(hessex,hess,2*nts,errhs)
      call derr(gradtargex,gradtarg,2*ntt,errgt)
      call derr(hesstargex,hesstarg,2*nts,errht)

      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(6) = 1
c
c
c
c
cc      now test source to source  + target, charge + dipole
c       with potentials
c
      write(6,*) 'testing stost, charge + dipole, potentials'

      call cfmm2d_st_cd_p(eps,nsrc,sources,charges,dipstr,
     1        pot,ntarg,targ,pottarg)
c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(pottargex,2*ntt)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo
      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      errgs = 0
      errgt = 0

      errhs = 0
      errht = 0
      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(7) = 1

c
c
cc      now test source to source  + target, charge + dipole
c       with gradients
c
      write(6,*) 'testing stost, charge + dipole, gradients'

      call cfmm2d_st_cd_g(eps,nsrc,sources,charges,dipstr,
     1        pot,grad,ntarg,targ,pottarg,gradtarg)
c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(gradex,2*nts)
      call dzero(pottargex,2*ntt)
      call dzero(gradtargex,2*ntt)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo
      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      call derr(gradex,grad,2*nts,errgs)
      call derr(gradtargex,gradtarg,2*ntt,errgt)

      errhs = 0
      errht = 0
      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(8) = 1

c
c
cc      now test source to source  + target, charge + dipole
c       with hessians
c

      write(6,*) 'testing stost, charge + dipole, hessians'
      call cfmm2d_st_cd_h(eps,nsrc,sources,charges,dipstr,
     1        pot,grad,hess,ntarg,targ,pottarg,gradtarg,
     2        hesstarg)
c
cc       test against exact potential
c
      call dzero(potex,2*nts)
      call dzero(gradex,2*nts)
      call dzero(hessex,2*nts)
      call dzero(pottargex,2*ntt)
      call dzero(gradtargex,2*ntt)
      call dzero(hesstargex,2*ntt)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 3
      thresh = 1.0d-14

      call cfmm2dpart_direct(1,1,nsrc,1,nts,sources,ifcharge,
     1       charges,ifdipole,dipstr,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call cfmm2dpart_direct(1,1,nsrc,1,ntt,sources,ifcharge,
     1       charges,ifdipole,dipstr,targ,ifpgh,pottargex,
     2       gradtargex,hesstargex,thresh)

      do i=1,nts
        potexr(i) = real(potex(i))
        potr(i) = real(pot(i))
      enddo

      do i=1,ntt
        pottargexr(i) = real(pottargex(i))
        pottargr(i) = real(pottarg(i))
      enddo
      call derr(potexr,potr,nts,errps)
      call derr(pottargexr,pottargr,ntt,errpt)

      call derr(gradex,grad,2*nts,errgs)
      call derr(hessex,hess,2*nts,errhs)
      call derr(gradtargex,gradtarg,2*ntt,errgt)
      call derr(hesstargex,hesstarg,2*nts,errht)

      call errprint(errps,errgs,errhs,errpt,errgt,errht)
      if (errps .lt. eps .and. errgs .lt. eps .and. errhs .lt. eps .and.
     1     errpt .lt. eps .and. errgt .lt. eps .and. errht .lt. eps)
     1     ipass(9) = 1

      npass = 0
      do i = 1,ntests
         npass = npass + ipass(i)
      enddo

      open(unit=33,file='print_testres.txt',access='append')
      write(33,'(a,i2,a,i2,a)') 'Successfully completed ',npass,
     1   ' out of ',ntests,' tests in cfmm2d testing suite'
      close(33)

      stop
      end
c-----------------------------------------------------
      subroutine dzero(vec,n)
      implicit real *8 (a-h,o-z)
      real *8 vec(*)

      do i=1,n
         vec(i) = 0
      enddo

      return
      end
c------------------------------------
      subroutine derr(vec1,vec2,n,erra)
      implicit real *8 (a-h,o-z)
      real *8 vec1(*),vec2(*)

      ra = 0
      erra = 0
      do i=1,n
         ra = ra + vec1(i)**2
         erra = erra + (vec1(i)-vec2(i))**2
      enddo

      erra = sqrt(erra/ra)

      return
      end
c----------------------------------
      subroutine errprint(errps,errgs,errhs,errpt,errgt,errht)
      implicit real *8 (a-h,o-z)
 1100 format(3(2x,e11.5))

      write(6,*) 'error in sources'
      write(6,*) 'pot err, grad err, hess err'
      write(6,1100) errps,errgs,errhs
      write(6,*)
      write(6,*)
      write(6,* ) 'error in targets'
      write(6,*) 'pot err, grad err, hess err'
      write(6,1100) errpt,errgt,errht
      write(6,*)
      write(6,*)
      write(6,*)'==================='

      return
      end


      PROGRAM xratlsq
C     driver for routine ratlsq
      INTEGER NMAX
      PARAMETER(NMAX=100)
      INTEGER j,kk,mm
      DOUBLE PRECISION a,b,cof(NMAX),dev,eee,fit,fn,ratval,xs
      EXTERNAL fn
1     write(*,*) 'enter a,b,mm,kk'
      read(*,*,END=999) a,b,mm,kk
      call ratlsq(fn,a,b,mm,kk,cof,dev)
      do 11 j=1,mm+kk+1
        write(*,'(1x,a4,i3,a2,e27.15)') 'cof(',j,')=',cof(j)
11    continue
      write(*,*) 'maximum absolute deviation=',dev
      write(*,*) '    x        error        exact'
      write(*,*) '--------- ------------ ---------'
      do 12 j=1,50
        xs=a+(b-a)*(j-1.)/49.
        fit=ratval(xs,cof,mm,kk)
        eee=fn(xs)
        write(*,'(1x,f10.5,2e15.7)') xs,fit-eee,eee
12    continue
      goto 1
999   END
      FUNCTION fn(t)
      DOUBLE PRECISION fn,t
      fn=atan(t)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xratlsq.for


! Created by mus on 29/07/2021.
! Connectivty Matrix for global assembly
! See Bernhard, Schuberth. (2003) Thesis

function connectivity_matrix(N,ne)
    integer, intent(in)                             :: N, ne
    integer                                         :: i, j, c
    integer                                            connectivity_matrix(N+1,ne)

    c = 1
    do j=1,ne
        do i=1,N+1
            connectivity_matrix(i,j) = c
            c = c + 1
        end do
        c = c -1
    end do

end function


module array_utilities

    implicit none

    interface smooth_array
        module procedure smooth_array_2d, smooth_array_3d
    end interface

    interface array_offset_x
        module procedure array_offset_x_2d, array_offset_x_3d
    end interface

    interface array_offset_y
        module procedure array_offset_y_2d, array_offset_y_3d
    end interface

contains

    subroutine interpolate_in_z(input)
        implicit none
        real, allocatable, intent(inout) :: input(:,:,:)

        real, allocatable :: temp_z(:,:,:)
        integer :: nx, ny, nz

        nx = size(input, 1)
        nz = size(input, 2)
        ny = size(input, 3)

        allocate(temp_z(nx,nz,ny))
        temp_z = input

        deallocate(input)
        allocate(input(nx,nz-1,ny))

        input = (temp_z(:,1:nz-1,:) + temp_z(:,2:nz,:))/2

        deallocate(temp_z)

    end subroutine interpolate_in_z

    subroutine array_offset_x_3d(input_array, output_array)
        implicit none
        real,              intent(in)    :: input_array(:,:,:)
        real, allocatable, intent(inout) :: output_array(:,:,:)

        integer :: nx,nz,ny

        nx = size(input_array,1)
        nz = size(input_array,2)
        ny = size(input_array,3)

        if (allocated(output_array)) deallocate(output_array)
        allocate(output_array(nx+1, nz, ny))

        output_array(1,:,:)    = (1.5 * input_array(1,:,:)  - 0.5 * input_array(2,:,:))    ! extrapolate past the end
        output_array(2:nx,:,:) = (input_array(1:nx-1,:,:) + input_array(2:nx,:,:) ) / 2    ! interpolate between points
        output_array(nx+1,:,:) = (1.5 * input_array(nx,:,:)  - 0.5 * input_array(nx-1,:,:))! extrapolate past the end

    end subroutine

    subroutine array_offset_x_2d(input_array, output_array)
        implicit none
        real,              intent(in)    :: input_array(:,:)
        real, allocatable, intent(inout) :: output_array(:,:)

        integer :: nx,ny

        nx = size(input_array,1)
        ny = size(input_array,2)

        if (allocated(output_array)) deallocate(output_array)
        allocate(output_array(nx+1, ny))

        output_array(1,:)    = (1.5 * input_array(1,:)  - 0.5 * input_array(2,:))    ! extrapolate past the end
        output_array(2:nx,:) = (input_array(1:nx-1,:) + input_array(2:nx,:) ) / 2    ! interpolate between points
        output_array(nx+1,:) = (1.5 * input_array(nx,:)  - 0.5 * input_array(nx-1,:))! extrapolate past the end

    end subroutine

    subroutine array_offset_y_2d(input_array, output_array)
        implicit none
        real,              intent(in)    :: input_array(:,:)
        real, allocatable, intent(inout) :: output_array(:,:)

        integer :: nx,nz,ny

        nx = size(input_array,1)
        ny = size(input_array,2)

        if (allocated(output_array)) deallocate(output_array)
        allocate(output_array(nx, ny+1))

        output_array(:,1)    = (1.5 * input_array(:,1)  - 0.5 * input_array(:,2))    ! extrapolate past the end
        output_array(:,2:ny) = (input_array(:,1:ny-1) + input_array(:,2:ny) ) / 2    ! interpolate between points
        output_array(:,ny+1) = (1.5 * input_array(:,ny)  - 0.5 * input_array(:,ny-1))! extrapolate past the end

    end subroutine

    subroutine array_offset_y_3d(input_array, output_array)
        implicit none
        real,              intent(in)    :: input_array(:,:,:)
        real, allocatable, intent(inout) :: output_array(:,:,:)

        integer :: nx,nz,ny

        nx = size(input_array,1)
        nz = size(input_array,2)
        ny = size(input_array,3)

        if (allocated(output_array)) deallocate(output_array)
        allocate(output_array(nx, nz, ny+1))

        output_array(:,:,1)    = (1.5 * input_array(:,:,1)  - 0.5 * input_array(:,:,2))    ! extrapolate past the end
        output_array(:,:,2:ny) = (input_array(:,:,1:ny-1) + input_array(:,:,2:ny) ) / 2    ! interpolate between points
        output_array(:,:,ny+1) = (1.5 * input_array(:,:,ny)  - 0.5 * input_array(:,:,ny-1))! extrapolate past the end

    end subroutine
    !>----------------------------------------------------------
    !! Generate an array with n_values elements spanning the range min to max
    !!
    !! This is similar to the matlab/numpy/etc linspace function
    !!
    !!----------------------------------------------------------
    subroutine linear_space(input_array, min_value, max_value, n_values)
        implicit none
        real,   intent(inout), allocatable :: input_array(:)
        real,   intent(in)  :: min_value, max_value
        integer,intent(in)  :: n_values

        integer :: i

        if (allocated(input_array)) then
            if (size(input_array)/=n_values) then
                deallocate(input_array)
            endif
        endif
        ! note, this can't be an else statement because the above block might change the result
        if (.not.allocated(input_array)) then
            allocate(input_array(n_values))
        endif

        do i=1,n_values
            input_array(i) = (i-1.0)/real(n_values-1.0) * (max_value - min_value) + min_value
        enddo

    end subroutine linear_space

    pure function check_array_dims(input_array, d1, d2, d3, d4, d5) result(passed)
        implicit none
        real,    intent(in) :: input_array(:,:,:,:,:)
        integer, intent(in) :: d1, d2, d3, d4, d5
        logical :: passed

        passed = .True.

        if (size(input_array,1)/=d1) passed = .False.
        if (size(input_array,2)/=d2) passed = .False.
        if (size(input_array,3)/=d3) passed = .False.
        if (size(input_array,4)/=d4) passed = .False.
        if (size(input_array,5)/=d5) passed = .False.

    end function check_array_dims

    !>----------------------------------------------------------
    !! Calculate the weights between the positions bestpos and nextpos
    !! based on the distance between match and indata(nextpos) (normalized by nextpos - bestpos)
    !! assumes indata is monotonically increasing,
    !! bestpos must be set prior to entry
    !! nextpos is calculated internally (either 1, bestpos+1, or n)
    !!
    !!----------------------------------------------------------
    function calc_weight(indata, bestpos, nextpos, match) result(weight)
        implicit none
        real :: weight
        real, dimension(:), intent(in) :: indata
        integer, intent(in) :: bestpos
        integer, intent(inout) :: nextpos
        real, intent(in) :: match

        integer :: n

        n=size(indata)

        if (match<indata(1)) then
            nextpos=1
            weight=1
        else
            if (bestpos==n) then
                nextpos=n
                weight=1
            else
                nextpos=bestpos+1
                weight=(indata(nextpos)-match) / (indata(nextpos) - indata(bestpos))
            endif
        endif

    end function

    !>------------------------------------------------------------
    !! Smooth an array (written for wind but will work for anything)
    !!
    !! Only smooths over the first (x) and second (y or z) or third (y or z) dimension
    !! ydim can be specified to allow working with (x,y,z) data or (x,z,y) data
    !! WARNING: this is a moderately complex setup to be efficient for the ydim=3 (typically large arrays, SLOW) case
    !! be careful when editing.
    !! For the complex case it pre-computes the sum of all columns for a given row,
    !! then to move from one column to the next it just has add the next column from the sums and subtracts the last one
    !! similarly, moving to the next row just means adding the next row to the sums, and subtracting the last one.
    !! Each point also has to be divided by N, but this decreases the compution from O(windowsize^2) to O(constant)
    !! Where O(constant) = 2 additions, 2 subtractions, and 1 divide regardless of windowsize!
    !!
    !! @param wind          3D array to be smoothed
    !! @param windowsize    size to smooth in both directions (i.e. the full window is this * 2 + 1)
    !! @param ysim          axis the y dimension is on (2 or 3) in the wind array
    !!
    !!------------------------------------------------------------
    subroutine smooth_array_3d(wind,windowsize,ydim)
        implicit none
        real, intent(inout), dimension(:,:,:):: wind    !> 3 dimensional wind field to be smoothed
        integer,intent(in)::windowsize                  !> halfwidth-1/2 of window to smooth over
                                                        ! Specified in grid cells, (+/- windowsize)
        integer,intent(in)::ydim                        !> the dimension to use for the y coordinate
                                                        ! It can be 2, or 3 (but not 1)
        real,allocatable,dimension(:,:,:)::inputwind    !> temporary array to store the input data in
        integer::i,j,k,nx,ny,nz,startx,endx,starty,endy ! various array indices/bounds

        ! Intermediate sums to speed up the computation
        ! Because these are accumulating values over the domain, use double precision
        ! in practice this doesn't seem to matter.
        double precision,allocatable,dimension(:) :: rowsums,rowmeans
        double precision :: cursum
        integer :: cur_n, curcol, ncols, nrows

        ncols = windowsize * 2 + 1
        nx = size(wind, 1)
        ny = size(wind, 2) !note, this is Z for the high-res domain (ydim=3)
        nz = size(wind, 3) !note, this could be the Y or Z dimension depending on ydim

        allocate(inputwind(nx,ny,nz)) ! Can't be module level because nx,ny,nz could change between calls,

        inputwind = wind !make a copy so we always use the unsmoothed data when computing the smoothed data
        ! if (( ( (windowsize*2+1)>nz) .or. ((windowsize*2+1)>nx) ) .and. (ydim==3)) then
        !     write(*,*) "It is OK to ignore this warning for most idealized (e.g. maybe ~2D) simulations"
        !     write(*,*) "WARNING smoothing windowsize*2+1 is larger than nx or ny."
        !     write(*,*) "  This might lead to artifacts in the wind field especially near the borders."
        !     write(*,*) "  NX         = ", nx
        !     write(*,*) "  NY         = ", nz
        !     write(*,*) "  windowsize = ", windowsize
        !     print*, "Image = ",this_image()
        ! endif

        !parallelize over a slower dimension (not the slowest because it is MUCH easier this way)
        ! as long as the inner loops (the array operations) are over the fastest dimension we are mostly OK
        !$omp parallel firstprivate(windowsize,nx,ny,nz,ydim), &
        !$omp private(i,j,k,startx,endx,starty,endy, rowsums,rowmeans,nrows,ncols,cursum), &
        !$omp shared(wind,inputwind)

        allocate(rowsums(nx)) !this is only used when ydim=3, so nz is really ny
        allocate(rowmeans(nx)) !this is only used when ydim=3, so nz is really ny
        nrows = windowsize * 2 + 1
        ncols = windowsize * 2 + 1

        !$omp do schedule(static)
        do j=1,ny

            ! so we pre-compute the sum over rows for each column in the current window
            if (ydim==3) then
                ! start by adding the outer row n+2 times
                ! effectively assumes it was set up for the grid cell before the first grid cell
                ! the first time through the loop will remove one iteration of outer row grid cells
                rowsums = inputwind(1:nx,j,1) * (windowsize+2)
                do i=2, min(windowsize,nz)
                    rowsums = rowsums + inputwind(1:nx, j, i)
                enddo
                if (windowsize > nz) then
                    rowsums = rowsums + inputwind(1:nx,j,nz) * (windowsize-nz)
                endif
            endif

            ! don't parallelize over this loop because it is much more efficient to be able to assume
            ! that you ran the previous row in serial for the slow (ydim=3) case
            do k=1,nz ! note this is y for ydim=3
                ! ydim=3 for the main model grid which is large and takes a long time
                if (ydim==3) then
                    starty  = max(2, k - windowsize)
                    endy    = min(nz, k + windowsize)
                    rowsums = rowsums - inputwind(1:nx, j, starty-1) + inputwind(1:nx, j, endy)

                    ! start by adding the outer row n+2 times
                    ! effectively assumes it was set up for the grid cell before the first grid cell
                    ! the first time through the loop will remove one iteration of outer row grid cells
                    rowmeans = rowsums / nrows
                    cursum = sum(rowmeans(2:windowsize)) + rowmeans(1) * (windowsize+2)
                endif

                do i=1,nx
                    if (ydim==3) then
                        startx = max(2, i - windowsize)
                        endx   = min(nx, i + windowsize)
                        cursum = cursum - rowmeans(startx-1) + rowmeans(endx)

                        wind(i,j,k) = cursum / ncols

                    else ! ydim==2
                        ! ydim=2 for the input data which is a small grid, thus cheap so we still use the slow method
                        !first find the current window bounds
                        startx=max(1, i - windowsize)
                        endx  =min(nx,i + windowsize)
                        starty=max(1, j - windowsize)
                        endy  =min(ny,j + windowsize)
                        ! then compute the mean within that window (sum/n)
                        ! note, artifacts near the borders (mentioned in ydim==3) don't affect this
                        ! because the borders *should* be well away from the domain
                        ! if the forcing data are not much larger than the model domain this *could* create issues
                        wind(i,j,k) = sum(inputwind(startx:endx,starty:endy,k)) &
                                       / ((endx-startx+1)*(endy-starty+1))
                    endif
                enddo
            enddo
        enddo
        !$omp end do
        deallocate(rowmeans,rowsums)
        !$omp end parallel

        deallocate(inputwind)
    end subroutine smooth_array_3d

    subroutine smooth_array_2d(input,windowsize)
        implicit none
        real, intent(inout), dimension(:,:):: input     !> 2 dimensional input field to be smoothed
        integer,intent(in)::windowsize                  !> halfwidth-1/2 of window to smooth over
                                                        ! Specified in grid cells, (+/- windowsize)
        real,allocatable,dimension(:,:)::inputtemp      !> temporary array to store the input data in
        integer::i,j,nx,ny,startx,endx,starty,endy      ! various array indices/bounds
        ! intermediate sums to speed up the computation
        real,allocatable,dimension(:) :: rowsums,rowmeans
        real :: cursum
        integer :: cur_n,curcol,ncols,nrows

        nx = size(input,1)
        ny = size(input,2)

        allocate(inputtemp(nx,ny))

        inputtemp = input !make a copy so we always use the unsmoothed data when computing the smoothed data
        ! if ((windowsize*2+1)>nx) then
        !     write(*,*) "WARNING can not operate if windowsize*2+1 is larger than nx"
        !     write(*,*) "NX         = ", nx
        !     write(*,*) "windowsize = ", windowsize
        !     stop
        ! endif

        !parallelize over a slower dimension (not the slowest because it is MUCH easier this way)
        ! as long as the inner loops (the array operations) are over the fastest dimension we are mostly OK
        !$omp parallel firstprivate(windowsize,nx,ny), &
        !$omp private(i,j,startx,endx,starty,endy, rowsums,rowmeans,nrows,ncols,cursum), &
        !$omp shared(input,inputtemp)
        allocate(rowsums(nx))
        allocate(rowmeans(nx))
        nrows = min(nx,windowsize * 2 + 1)
        ncols = min(ny,windowsize * 2 + 1)
        !$omp do schedule(static)
        do j=1,ny

            ! so we pre-compute the sum over rows for each column in the current window
            rowsums = 0
            do i = -1*windowsize, windowsize, 1
                starty = max(1,min(ny,j+i))
                rowsums = rowsums + inputtemp(1:nx,starty)
            enddo

            ! for a parallel algorithm (in 2D) we recompute the row sums for every y
            rowmeans = rowsums / nrows
            cursum = sum(rowmeans(1:windowsize)) + rowmeans(1) * (windowsize + 1)

            do i=1,nx
                ! if we are pinned to the left edge
                if ((i - windowsize)<=1) then
                    startx = 1
                    endx   = i + windowsize
                    cursum = cursum - rowmeans(startx) + rowmeans(endx)
                ! if we are pinned to the right edge
                else if ((i + windowsize) > nx) then
                    startx = i - windowsize
                    endx   = nx
                    cursum = cursum - rowmeans(startx-1) + rowmeans(endx)
                ! if we are in the middle (this is the most common)
                else
                    startx = i - windowsize
                    endx   = i + windowsize
                    cursum = cursum - rowmeans(startx-1) + rowmeans(endx)
                endif

                input(i,j) = cursum / ncols

            enddo
        enddo
        !$omp end do
        deallocate(rowmeans,rowsums)
        !$omp end parallel

        deallocate(inputtemp)
    end subroutine smooth_array_2d

    !>------------------------------------------------------------
    !! Check that two model grids have the same shape
    !!
    !! If the size of all dimensions in data1 and data2 are not exactly the same the model will stop
    !!
    !! @param data1     First 3D array to check dimension sizes
    !! @param data2     Second 3D array to check dimension sizes
    !!
    !!------------------------------------------------------------
    subroutine check_shapes_3d(data1,data2)
        implicit none
        real,dimension(:,:,:),intent(in)::data1,data2
        integer :: i
        do i=1,3
            if (size(data1,i).ne.size(data2,i)) then
                write(*,*) "Restart file 3D dimensions don't match domain"
                write(*,*) shape(data1)
                write(*,*) shape(data2)
                stop
            endif
        enddo
    end subroutine check_shapes_3d

    !>------------------------------------------------------------
    !! Swap the last two dimensions of an array
    !!
    !! Call reshape after finding the nx,ny,nz values
    !!
    !! @param data     3D array to be reshaped
    !!
    !!------------------------------------------------------------
    subroutine swap_y_z_dimensions(data)
        implicit none
        real,dimension(:,:,:),intent(inout),allocatable :: data
        real,dimension(:,:,:), allocatable :: temporary_data
        integer :: nx,ny,nz

        nx=size(data,1)
        ny=size(data,2)
        nz=size(data,3)
        allocate(temporary_data(nx,nz,ny))
        temporary_data = reshape(data, [nx,nz,ny], order=[1,3,2])

        deallocate(data)
        allocate(data(nx,nz,ny))
        data=temporary_data

    end subroutine swap_y_z_dimensions

end module array_utilities


! { dg-do compile }
! PR 18197: Check that dummy functions with RESULT variable and dimension works.
module innerfun
contains
  function f(n,x) result(y)
    integer, intent(in) :: n
    real, dimension(:), intent(in) :: x
    real, dimension(n) :: y
    y = 1
  end function f
end module innerfun

module outerfun
contains
   subroutine foo(n,funname)
     integer, intent(in) :: n
     real, dimension(n) :: y
     real, dimension(2) :: x
     interface
       function funname(n,x) result(y)
         integer, intent(in) :: n
         real, dimension(:), intent(in) :: x
         real, dimension(n)  :: y
       end function funname
     end interface

     y = funname(n, (/ 0.2, 0.3 /) )

   end subroutine foo
end module outerfun

program test
   use outerfun
   use innerfun
   call foo(3,f)
end program test

! { dg-final { cleanup-modules "innerfun outerfun" } }