      PROGRAM ERFTST
C------------------------------------------------------------------
C FORTRAN 77 program to test ERF and related functions.
C
C  Method:
C
C     Accuracy test compare function values against local Taylor's
C     series expansions.  Derivatives for erfc(x) are expressed as
C     repeated integrals of erfc(x).  These are generated from the
C     recurrence relation using a technique due to Gautschi (see
C     references).
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C              IBETA  - The radix of the floating-point system
C              IT     - The number of base-ibeta digits in the
C                       significant of a floating-point number
C              EPS    - The smallest positive floating-point
C                       number such that 1.0+EPS .NE. 1.0
C              XMIN   - The smallest non-vanishing floating-point
C                       integral power of the radix
C              XMAX   - The largest finite floating-point number
C
C     REN(K) - A function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  References: "Performance evaluation of programs for the error
C               and complementary error functions", W. J. Cody,
C               submitted for publication.
C
C              "Evaluation of the repeated integrals of the coerror
C               function", W. Gautschi, TOMS 3, 1977, pp. 240-252.
C
C  Latest modification: March 12, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD,N0,N1
CS    REAL  ERF,ERFC,ERFCX,
      DOUBLE PRECISION DERF,DERFC,DERFCX,
     1    A,AIT,ALBETA,B,BETA,C,CONV,C1,C2,DEL,EPS,EPSCON,EPSNEG,FF,
     2    FUNC1,FUNC2,FUNC3,F0,HALF,ONE,R,REN,R1,R6,R7,SC,SIXTEN,
     3    THRESH,TEN,TWO,U,V,W,X,XBIG,XC,XL,XMAX,XMIN,XN,XN1,X99,
     4    Z,ZERO,ZZ
      DIMENSION R1(500)
C------------------------------------------------------------------
C   C1 = 1/sqrt(pi)
C------------------------------------------------------------------
CS    DATA ZERO,HALF,ONE,TWO,TEN/0.0E0,0.5E0,1.0E0,2.0E0,10.0E0/,
CS   1     SIXTEN,THRESH,X99/16.0E0,0.46875E0,-999.0E0/,
CS   2     C1/5.6418958354775628695E-1/
      DATA ZERO,HALF,ONE,TWO,TEN/0.0D0,0.5D0,1.0D0,2.0D0,10.0D0/,
     1     SIXTEN,THRESH,X99/16.0D0,0.46875D0,-999.0D0/,
     2     C1/5.6418958354775628695D-1/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
CS    FUNC1(X) = ERF(X)
CS    FUNC2(X) = ERFC(X)
CS    FUNC3(X) = ERFCX(X)
      CONV(I) = DBLE(I)
      FUNC1(X) = DERF(X)
      FUNC2(X) = DERFC(X)
      FUNC3(X) = DERFCX(X)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      C = ABS(AIT*ALBETA) + TEN
      A = ZERO
      B = THRESH
      N = 2000
      XN = CONV(N)
      JT = 0
      N0 = (IBETA/2)*(IT+5)/6+4
C-----------------------------------------------------------------
C  Determine largest argument for ERFC test by Newton iteration
C-----------------------------------------------------------------
      C2 = LOG(XMIN) + LOG(ONE/C1)
      XBIG = SQRT(-C2)
   50 X = XBIG
         F0 = X*X
         FF = F0 + HALF/F0 + LOG(X) + C2
         F0 = X+X + ONE/X - ONE/(X*F0)
         XBIG = X - FF/F0
         IF (ABS(X-XBIG)/X .GT. TEN*EPS) GO TO 50
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 5
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            IF (J .EQ. 1) THEN
C-----------------------------------------------------------------
C  Test erf against double series expansion
C-----------------------------------------------------------------
                  F0 = CONV(N0)
                  FF = F0+F0+ONE
                  Z = X*X
                  W = Z+Z
                  U = ZERO
                  V = ZERO
                  DO 60 K = 1, N0
                     U = -Z/F0*(ONE+U)
                     V = W/FF*(ONE+V)
                     F0 = F0 - ONE
                     FF = FF - TWO
   60             CONTINUE
                  V = C1*(X+X)*(((U*V+(U+V))+HALF)+HALF)
                  U = FUNC1(X)
               ELSE
C-----------------------------------------------------------------
C  Test erfc or scaled erfc against expansion in repeated
C   integrals of the coerror function.
C-----------------------------------------------------------------
                  Z = X + HALF
                  X = Z - HALF
                  R = ZERO
                  IF (X .LE. ONE) THEN
                        N0 = 499
                     ELSE
                        N0 = MIN(499,INT(C/(ABS(LOG(Z)))))
                  END IF
                  N1 = N0
                  XN1 = CONV(N1+1)
                  DO 100 K=1,N0
                     R = HALF/(Z+XN1*R)
                     R1(N1) = R
                     N1 = N1 - 1
                     XN1 = XN1 - ONE
  100             CONTINUE
                  FF = C1/(Z+R1(1))
                  IF ((J/2)*2 .EQ. J) THEN
                        F0 = FUNC2(Z)*EXP(X+HALF*HALF)
                        U = FUNC2(X)
                     ELSE
                        F0 = FUNC3(Z)
                        U = FUNC3(X)
                  END IF
                  SC = F0/FF
C-----------------------------------------------------------------
C  Scale things to avoid premature underflow
C-----------------------------------------------------------------
                  EPSCON = F0
                  FF = SIXTEN*FF/EPS
                  DO 110 N1=1,N0
                     FF = R1(N1)*FF
                     R1(N1) = FF * SC
                     IF (R1(N1) .LT. EPSCON ) THEN
                        K = N1
                        GO TO 111
                     END IF
  110             CONTINUE
  111             V = R1(K)
                  DO 120 N1 = 1, K-1
                     V = V + R1(K-N1)
  120             CONTINUE
C-----------------------------------------------------------------
C  Remove scaling here
C-----------------------------------------------------------------
                  V = V*EPS/SIXTEN + F0
            END IF
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (U - V) / U
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         IF (J .EQ. 1) THEN
               WRITE (IOUT,1000)
               WRITE (IOUT,1010) N,A,B
               WRITE (IOUT,1011) K1
            ELSE IF ((J/2)*2 .EQ. J) THEN
               WRITE (IOUT,1001)
               WRITE (IOUT,1010) N,A,B
               WRITE (IOUT,1012) K1
            ELSE
               WRITE (IOUT,1002)
               WRITE (IOUT,1010) N,A,B
               WRITE (IOUT,1013) K1
         END IF
         WRITE (IOUT,1015) K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         IF (J .EQ. 1) THEN
               A = B
               B = TWO
            ELSE IF (J .EQ. 3) THEN
               A = B
               B = AINT(XBIG*SIXTEN)/SIXTEN-HALF
            ELSE IF (J .EQ. 4) THEN
               B = TEN + TEN
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C  First check values for negative arguments.
C-----------------------------------------------------------------
      WRITE (IOUT,1025)
      WRITE (IOUT,1030) IBETA
      X = ZERO
      DEL = -HALF
      DO 350 I = 1, 10
         U = FUNC1(X)
         A = U + FUNC1(-X)
         IF (A*U .NE. ZERO) A = AIT + LOG(ABS(A/U))/ALBETA
         V = FUNC2(X)
         B = U + V - ONE
         IF (B .NE. ZERO) B = AIT + LOG(ABS(B))/ALBETA
         W = FUNC3(X)
         C = AINT(X*SIXTEN)/SIXTEN
         R = (X-C)*(X+C)
         C = (EXP(C*C)*EXP(R)*V-W)/W
         IF (C .NE. ZERO) C = MAX(ZERO,AIT + LOG(ABS(C))/ALBETA)
         WRITE (IOUT,1031) X,A,B,C
         X = X + DEL
  350 CONTINUE
C-----------------------------------------------------------------
C  Next, test with special arguments
C-----------------------------------------------------------------
      WRITE (IOUT,1040)
      Z = XMAX
      ZZ = FUNC1(Z)
      WRITE (IOUT,1041) Z,ZZ
      Z = ZERO
      ZZ = FUNC1(Z)
      WRITE (IOUT,1041) Z,ZZ
      ZZ = FUNC2(Z)
      WRITE (IOUT,1042) Z,ZZ
      Z = -XMAX
      ZZ = FUNC2(Z)
      WRITE (IOUT,1042) Z,ZZ
C-----------------------------------------------------------------
C  Test of error returns
C-----------------------------------------------------------------
      WRITE (IOUT,1050)
      W = XBIG
      Z = W*(ONE-HALF*HALF)
      WRITE (IOUT,1052) Z
      ZZ = FUNC2(Z)
      WRITE (IOUT,1062) ZZ
      Z = W*(ONE+TEN*EPS)
      WRITE (IOUT,1053) Z
      ZZ = FUNC2(Z)
      WRITE (IOUT,1062) ZZ
      W = XMAX
      IF (C1 .LT. XMAX*XMIN) W = C1/XMIN
      Z = W*(ONE-ONE/SIXTEN)
      WRITE (IOUT,1054) Z
      ZZ = FUNC3(Z)
      WRITE (IOUT,1064) ZZ
      W = -SQRT(LOG(XMAX/TWO))
      Z = W*(ONE-ONE/TEN)
      WRITE (IOUT,1055) Z
      ZZ = FUNC3(Z)
      WRITE (IOUT,1064) ZZ
      Z = W*(ONE+TEN*EPS)
      WRITE (IOUT,1056) Z
      ZZ = FUNC3(Z)
      WRITE (IOUT,1064) ZZ
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of erf(x) vs double series expansion'//)
 1001 FORMAT(///' Test of erfc(x) vs exp(x+1/4) SUM i^n erfc(x+1/2)'//)
 1002 FORMAT('1Test of exp(x*x) erfc(x) vs SUM i^n erfc(x+1/2)'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F7.3,',',F7.3,')'//)
 1011 FORMAT('    ERF(X) was larger',I6,' times,')
 1012 FORMAT('   ERFC(X) was larger',I6,' times,')
 1013 FORMAT('  ERFCX(X) was larger',I6,' times,')
 1015 FORMAT(14X,' agreed',I6,' times, and'/
     1    10X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4E3,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6E3)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1025 FORMAT('1Special Tests'//)
 1030 FORMAT(7X,'Estimated loss of base',i3,'significant digits in'//
     1       3X,'X',5X,'Erf(x)+Erf(-x)',3X,'Erf(x)+Erfc(x)-1',
     1       3X,'Erfcx(x)-exp(x*x)*erfc(x)'/)
 1031 FORMAT(F7.3,3F16.2)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT('   ERF (',E13.6E3,') = ',E13.6E3//)
 1042 FORMAT('  ERFC (',E13.6E3,') = ',E13.6E3//)
 1050 FORMAT(' Test of Error Returns'///)
 1052 FORMAT(' ERFC will be called with the argument',E13.6E3,/
     1    ' This should not underflow'//)
 1053 FORMAT(' ERFC will be called with the argument',E13.6E3,/
     1    ' This may underflow'//)
 1054 FORMAT(' ERFCX will be called with the argument',E13.6E3,/
     1    ' This should not underflow'//)
 1055 FORMAT(' ERFCX will be called with the argument',E13.6E3,/
     1    ' This should not overflow'//)
 1056 FORMAT(' ERFCX will be called with the argument',E13.6E3,/
     1    ' This may overflow'//)
 1062 FORMAT(' ERFC returned the value',E13.6E3///)
 1064 FORMAT(' ERFCX returned the value',E13.6E3///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of ERF test program ----------
      END


!*==dznrm2.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b DZNRM2
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       COMPLEX*16 X(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DZNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!>    DZNRM2 := sqrt( x**H*x )
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is COMPLEX*16 array, dimension (N)
!>         complex vector with N elements
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of X
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup double_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  -- This version written on 25-October-1982.
!>     Modified on 14-October-1993 to inline the call to ZLASSQ.
!>     Sven Hammarling, Nag Ltd.
!> \endverbatim
!>
!  =====================================================================
      DOUBLE PRECISION FUNCTION DZNRM2(N,X,Incx)
      IMPLICIT NONE
!*--DZNRM279
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      INTEGER Incx , N
!     ..
!     .. Array Arguments ..
      COMPLEX*16 X(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION norm , scale , ssq , temp
      INTEGER ix
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , DIMAG , SQRT
!     ..
      IF ( N<1 .OR. Incx<1 ) THEN
         norm = ZERO
      ELSE
         scale = ZERO
         ssq = ONE
!        The following loop is equivalent to this call to the LAPACK
!        auxiliary routine:
!        CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
!
         DO ix = 1 , 1 + (N-1)*Incx , Incx
            IF ( DBLE(X(ix))/=ZERO ) THEN
               temp = ABS(DBLE(X(ix)))
               IF ( scale<temp ) THEN
                  ssq = ONE + ssq*(scale/temp)**2
                  scale = temp
               ELSE
                  ssq = ssq + (temp/scale)**2
               ENDIF
            ENDIF
            IF ( DIMAG(X(ix))/=ZERO ) THEN
               temp = ABS(DIMAG(X(ix)))
               IF ( scale<temp ) THEN
                  ssq = ONE + ssq*(scale/temp)**2
                  scale = temp
               ELSE
                  ssq = ssq + (temp/scale)**2
               ENDIF
            ENDIF
         ENDDO
         norm = scale*SQRT(ssq)
      ENDIF
!
      DZNRM2 = norm
!
!     End of DZNRM2.
!
      END FUNCTION DZNRM2


c Fortran 77 fizz buzz implementation for numbers up to 100.

      program fizzbuzz

      integer i

c     For loop from 1 to 100, inclusive
      do 10 i = 1, 100
          if (mod(i, 15) .EQ. 0) then
              write(*, '(A)') 'Fizz buzz'
          elseif (mod(i, 3) .EQ. 0) then
              write(*, '(A)') 'Fizz'
          elseif (mod(i, 5) .EQ. 0) then
              write(*, '(A)') 'Buzz'
          else
              write(*, '(I0)') i
          endif
10    continue

      stop
      end


program hip_dger

  use iso_c_binding
  use hip
  use hip_blas

  implicit none

  integer, parameter ::  m = 100, n = 100
  double precision, parameter ::  alpha = 1.1d0
  integer, parameter :: bytes_per_element = 8 !double precision

  double precision, allocatable, target, dimension(:) :: hx, hy, hA

  type(c_ptr) :: handle = c_null_ptr
  type(c_ptr) :: dx = c_null_ptr, dy = c_null_ptr, dA = c_null_ptr
  integer(c_size_t), parameter :: Nbytes = m*bytes_per_element

  integer :: i
  double precision :: error

  write(*,*) "Starting dger test"

  call hipblasCheck(hipblasCreate(handle))

  allocate(hx(m))
  allocate(hy(n))
  allocate(ha(m*n))

  hx(:) = 1.d0
  hy(:) = 1.d0
  hA(:) = 1.d0

  ! Allocate device memory
  call hipCheck(hipMalloc(dx,Nbytes))
  call hipCheck(hipMalloc(dy,Nbytes))
  call hipCheck(hipMalloc(dA,Nbytes*n))

  !Transfer from host to device
  call hipCheck(hipMemcpy(dx, c_loc(hx), Nbytes, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dy, c_loc(hy), Nbytes, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dA, c_loc(hA), Nbytes*n, hipMemcpyHostToDevice))

  call hipblasCheck(hipblasDger(handle,m,n,alpha,dx,1,dy,1,dA,m))

  call hipCheck(hipDeviceSynchronize())

  ! Transfer data back to host memory
  call hipCheck(hipMemcpy(c_loc(hA), dA, Nbytes*n, hipMemcpyDeviceToHost))

  do i = 1,m*n
     error = abs(2.1d0 - hA(i))
     if( error > 10*epsilon(error) )then
        write(*,*) "dger FAILED! Error bigger than max! Error = ", error, "hA(i) = ", hA(i)
        call exit(1)
     end if
  end do

  call hipCheck(hipFree(dx))
  call hipCheck(hipFree(dy))
  call hipCheck(hipFree(dA))

  call hipblasCheck(hipblasDestroy(handle))

  deallocate(hx)
  deallocate(hy)
  deallocate(hA)

  write(*,*) "dger PASSED!"

end program hip_dger


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! This file contains the main logic for calculating the potential due to a single
!! wire and to an array of wires. These functions (that are the most expensive part
!! of the code) are then called from python.
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! If you use this code in your work, please cite the following paper:
!!
!! A. Bussy, G. Pizzi, M. Gibertini, Strain-induced polar discontinuities
!! in 2D materials from combined first-principles and Schroedinger-Poisson
!! simulations, Phys. Rev. B 96, 165438 (2017).
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! This code is released under a MIT license, see LICENSE.txt file in the main
!! folder of the code repository, hosted on GitHub at
!! https://github.com/giovannipizzi/schrpoisson-2dmaterials
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! FORTRAN code version: 1.0.0
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!==================================================================
!==================NONPERIODIC FUNCTIONS===========================

subroutine v_wire_nonperiodic(x,lambda,potential)
  !! This subroutine computes the unscreened potential due to an infinite (along y)
  !! charged wire at a distance x

  double precision, intent(in) :: x
  !! x is the distance in ang between the wire and the point of interest
  double precision, intent(in) :: lambda
  !! lambda is the line charged density of the wire in e/cm

  double precision, intent(out) :: potential
  !! in V
  double precision :: lamb
  !! lambda in units of e/ang

  double precision :: PI, EPSILON0
  parameter(PI = 3.1415926535897932d0)
  parameter(EPSILON0 = 0.0055263496) ! in e/(V*ang)

  !first off, need lambda in e/ang
  lamb = lambda*1.E-8

  potential = -lamb/(2.*PI*EPSILON0) * LOG(x)

end subroutine v_wire_nonperiodic

subroutine v_array_wire_nonperiodic(coord,x,rho_in,potential,n)
  !! this subroutine computes the potential at a point from a charge density
  !! (array of wires with different charges)

  double precision, intent(in) :: coord
  !! coordinate of point of interest along x axis (in ang)
  double precision, intent(in), dimension(n) :: x
  !! the array of grid points in ang
  double precision, intent(in), dimension(n) :: rho_in
  !! the charge density in e/cm defined at each grid point
  double precision, intent(out) :: potential
  !! the potential in V at point coord due to array of wires
  integer, intent(in) :: n
  !! dimension of all arrays

  double precision :: potr
  !! temporary storing of potential on the right (for integration)
  double precision :: potl
  !! temporary storing of potential on the left (for integration)

  integer :: i

  ! numerical integration to get potential
  do i=1,n-1 ! up to n-1 because we use trapezoidal method for integration
     call v_wire_nonperiodic(ABS(coord-x(i)),rho_in(i),potl)
     call v_wire_nonperiodic(ABS(coord-x(i+1)),rho_in(i+1),potr)
     potential = potential + 0.5*(potr+potl) !*(x(2)-x(1))
  end do
end subroutine v_array_wire_nonperiodic

subroutine full_v_array_wire_nonperiodic(x,rho_in,potential,n)
  !! this subroutine computes the potential at each grid point from a charge density
  !! (array of wires with diffrent charges)

  double precision, intent(in), dimension(n) :: x
  !! the array of grid points in ang
  double precision, intent(in), dimension(n) :: rho_in
  !! the charge density in e/cm defined at each grid point
  double precision, intent(out), dimension(n) :: potential
  !! the potential in V at each grid point due to array of wires
  integer, intent(in) :: n
  !! dimension of all arrays

  double precision :: coord
  double precision :: pot ! for temporary storage of potential
  integer :: i

  do i=1,n
     pot = 0.0 ! because of the += in the v_array_wire_periodic subroutine
     coord = (i-1)*(x(2)-x(1))
     call v_array_wire_nonperiodic(coord,x,rho_in,pot,n)
     potential(i) = pot
  end do

end subroutine full_v_array_wire_nonperiodic

subroutine nonperiodic_recursive_poisson(x,rho_in,alpha,max_iteration,potential,rho_out,n)
  !! this subroutine solves the screened Poisson equation for 2D materials
  !! with different polarizabilities

  double precision, intent(in), dimension(n) :: x
  !! the array containing the position of all grid points in ang
  double precision, intent(in), dimension(n) :: rho_in
  !! initial charge density in e/cm defined at each grid point
  double precision, intent(in), dimension(n) :: alpha
  !! the value of the polarizability at each grid point in e/V
  integer, intent(in) :: max_iteration
  !! the maximum amount of allowed iterations for the recursive Poisson algorithm
  double precision, intent(out), dimension(n) :: potential
  !! the solution of recursive Poisson in V defined at each grid point
  double precision, intent(out), dimension(n) :: rho_out
  !! The total charge density including polarization charges in e/cm at each grid point
  integer, intent(in) :: n
  !! dimension of all grid-related arrays

  integer :: i
  integer :: counter, subcounter
  integer, dimension(1) :: max_ind
  double precision :: beta
  double precision :: Vleft
  double precision, dimension(2) :: indicator ! used to check if there are oscillations while converging
  double precision :: h ! step size in ang
  double precision :: diff,diff_old ! allowed difference for convergence tests
  double precision, dimension(n) :: old_rho ! induced charge density before algorithm step
  double precision, dimension(n) :: new_rho
  double precision, dimension(n) :: dV ! the space derivative of the potential at each point
  double precision, dimension(n) :: aldV ! product of alpha and dV at each grid point
  double precision, dimension(n) :: V ! temporary storage of the potential
  logical :: conv

  !RESOLUTION

  h = x(2)-x(1)

  ! First off, one computes the unscreened potential due to rho_in
  ! One computes it a half grid point on the right, mainly to avoid things such as LOG(0)
  call full_v_array_wire_nonperiodic(x-0.5*h,rho_in,V,n)

  ! One computes the derivative of V at grid points using central finite difference
  do i=2,n
     dV(i) = 1./h * (V(i)-V(i-1))
  end do
  Vleft = 0.
  call v_array_wire_nonperiodic(-0.5*h,x,rho_in,Vleft,n)
  ! dV(1) = dV(2)
  dV(1)= 1./h * (V(1)-Vleft)

  aldV = alpha*dV

  ! now one computes the induced charge density at each point in e/ang

  do i=2,n-1
     old_rho(i) = 1./(2*h) * (aldV(i+1)-aldV(i-1))
  end do

  old_rho(1) = 1./h * (aldV(2)-aldV(1))
  old_rho(n) = 1./h * (aldV(n)-aldV(n-1))

  ! change it to e/cm
  old_rho = old_rho*h ! e/ang
  old_rho = old_rho*1.E8 ! e/cm

  ! old_rho(1)=old_rho(2)
  ! old_rho(n)=old_rho(n-1)

  ! time for recursive algorithm
  counter = 0
  subcounter = 0
  beta =0.5
  diff = 10000.
  conv = .TRUE.
  max_ind =  MAXLOC(old_rho)

  do while (diff > 1.E-4)
     counter = counter +1
     subcounter = subcounter +1
     diff_old = diff

     !print *,counter, diff

     if (counter > max_iteration) then
        print *, "WARNING: recursive Poisson algorithm does not converge fast enough"
        conv = .FALSE.
        EXIT
     end if

     ! update the potential including polarization charges
     call full_v_array_wire_nonperiodic(x-0.5*h,rho_in+old_rho,V,n)

     ! doing the same operations as before
     do i=2,n
        dV(i) = 1./h * (V(i)-V(i-1))
     end do
     Vleft=0.
     call v_array_wire_nonperiodic(-0.5*h,x,rho_in+old_rho,Vleft,n)
     dV(1) = 1./h * (V(1)-Vleft)
     ! dV(1) =dV(2)

     aldV = alpha*dV

     do i=2,n-1
        new_rho(i) = 1./(2*h) * (aldV(i+1)-aldV(i-1))
     end do

     new_rho(1) = 1./h * (aldV(2)-aldV(1))
     new_rho(n) = 1./h * (aldV(n)-aldV(n-1))

     ! need rho in e/cm
     new_rho = new_rho*h ! e/ang
     new_rho = new_rho*1.E8 ! e/cm

     !new_rho(1)=new_rho(2)
     !new_rho(n)=new_rho(n-1)

     indicator(MOD(counter, 2)+1) = old_rho(max_ind(1))-new_rho(max_ind(1))

     if (indicator(1)*indicator(2) < 0) then !there is an oscillation in the convergence
        beta = beta/1.5
        new_rho = 0.5*(new_rho+old_rho)
        subcounter = 0
     end if

     if (subcounter > 3) then
        beta = beta*2
        subcounter = 0
        if (beta>1.) then
           beta = 1.
        end if
     end if

     diff = ABS(MAXVAL(old_rho-new_rho))/ABS(MAXVAL(rho_in))

     old_rho = beta*new_rho + (1.-beta)*old_rho

  end do

  ! need to return a value of the potential defined on grid points, use linear interpolation
  do i=2,n
     potential(i) = 0.5*(V(i)+V(i-1))
  end do

  call v_array_wire_nonperiodic(-0.5*h,x,rho_in+old_rho,potential(1),n)
  potential(1) = 0.5*(potential(1)+V(1))
  rho_out = old_rho + rho_in ! total charge density

  !convergence check
  call full_v_array_wire_nonperiodic(x-0.5*h,rho_in+old_rho,V,n)

  !doing the same operations as before
  do i=2,n
     dV(i) = 1./h * (V(i)-V(i-1))
  end do
  dV(1) =dV(2)

  aldV = alpha*dV

  do i=2,n-1
     new_rho(i) = 1./(2*h) * (aldV(i+1)-aldV(i-1))
  end do

  !need rho in e/cm
  new_rho = new_rho*h !e/ang
  new_rho = new_rho*1.E8 ! e/cm

  new_rho(1)=new_rho(2)
  new_rho(n)=new_rho(n-1)

  if (conv .eqv. .TRUE.) then
     !print *, "Recursive Poisson algorithm converged in", counter, "steps."
     !print *, "Convergence check:", ABS(MAXVAL(old_rho-new_rho))/ABS(MAXVAL(rho_in))
  else
     print *, "Recursive Poisson algorithm could not converge after", max_iteration, "steps."
  end if

end subroutine nonperiodic_recursive_poisson

!==================================================================
!====================PERIODIC FUNCTIONS============================

subroutine v_wire_periodic(x,lambda,potential,period)
  !! This subroutine computes the unscreend potential due to a periodic array
  !! of charged wires at a distance x from one of them

  double precision, intent(in) :: x
  !! x is the distance in ang between the wire and the point of interest
  double precision, intent(in) :: lambda
  !! lambda is the line charged density of the wire in e/cm
  double precision, intent(out) :: potential
  !! in V
  double precision, intent(in) :: period
  !! periodicity of setup in ang

  double precision :: lamb
  !! lambda in units of e/ang

  double precision :: PI, EPSILON0
  parameter(PI = 3.1415926535897932d0)
  parameter(EPSILON0 = 0.0055263496) ! in e/(V*ang)

  ! first off, need lambda in e/ang
  lamb = lambda*1.E-8

  potential = -lamb/(2.*PI*EPSILON0) * LOG(SIN(PI/period*x))
end subroutine v_wire_periodic

subroutine v_array_wire_periodic(coord,x,rho_in,potential,n)
  !! this subroutine computes the potential at a point from a periodic
  !! charge density

  double precision, intent(in) :: coord
  !! coordinate of point of interest along x axis (in ang)
  double precision, intent(in), dimension(n) :: x
  !! the array of grid points in ang
  double precision, intent(in), dimension(n) :: rho_in
  !! the charge density in e/cm defined at each grid point
  double precision, intent(out) :: potential
  !! the potential in V at point coord due to array of wires
  integer, intent(in) :: n
  !! dimension of all arrays

  double precision :: potr
  !! temporary storing of potential on the right (for integration)
  double precision :: potl
  !! temporary storing of potential on the left (for integration)
  double precision :: period
  !! the period along the x axis in ang

  integer :: i

  period = x(n)-x(1)

  ! numerical integration to get potential
  do i=1,n-1 ! up to n-1 cuz one uses trapezoidal method for integration
     call v_wire_periodic(ABS(coord-x(i)),rho_in(i),potl,period)
     call v_wire_periodic(ABS(coord-x(i+1)),rho_in(i+1),potr,period)
     potential = potential + 0.5*(potr+potl) !*(x(2)-x(1))
  end do
end subroutine v_array_wire_periodic

subroutine full_v_array_wire_periodic(x,rho_in,potential,n)
  !! this subroutine computes the potential at each grid point from a
  !! charge density (array of wires with diffrent charges)

  double precision, intent(in), dimension(n) :: x
  !! the array of grid points in ang
  double precision, intent(in), dimension(n) :: rho_in
  !! the charge density in e/cm defined at each grid point
  double precision, intent(out), dimension(n) :: potential
  !! the potential in V at each grid point due to array of wires
  integer, intent(in) :: n
  !! dimension of all arrays

  double precision :: coord
  double precision :: pot ! for temporary storage of potential
  integer :: i

  do i=1,n

     pot = 0.0 ! because of the += in the v_array_wire_periodic subroutine
     coord = (i-1)*(x(2)-x(1))
     call v_array_wire_periodic(coord,x,rho_in,pot,n)
     potential(i) = pot

  end do

end subroutine full_v_array_wire_periodic

subroutine periodic_recursive_poisson(x,rho_in,alpha,max_iteration,potential,rho_out,n)
  !! this subroutine solves the screened Poisson equation for 2D materials
  !! with diffrent polarizabilities

  double precision, intent(in), dimension(n) :: x
  !! the array containing the position of all grid points in ang
  double precision, intent(in), dimension(n) :: rho_in
  !! initial charge density in e/cm defined at each grid point
  double precision, intent(in), dimension(n) :: alpha
  !! the value of the polarizability at each grid point in e/V
  integer, intent(in) :: max_iteration
  !! the maximum number of allowed iterations for the recursive Poisson algorithm
  double precision, intent(out), dimension(n) :: potential
  !! the solution of recursive Poisson in V defined at each grid point
  double precision, intent(out), dimension(n) :: rho_out
  !! The total charge density including polarization charges in e/cm at each grid point
  integer, intent(in) :: n
  !! dimension of all grid-related arrays

  integer :: i
  integer :: counter, subcounter
  integer, dimension(1) :: max_ind
  double precision :: beta
  double precision, dimension(2) :: indicator ! used to check if there are oscillations whilec converging
  double precision :: h ! step size in ang
  double precision :: diff,diff_old ! allowed difference for convergence tests
  double precision, dimension(n) :: old_rho ! induced charge density before algorithm step
  double precision, dimension(n) :: new_rho
  double precision, dimension(n) :: dV ! the space derivative of the potential at each point
  double precision, dimension(n) :: aldV ! product of alpha and dV at each grid point
  double precision, dimension(n) :: V !temporar storage of the potential
  logical :: conv

  h = x(2)-x(1)

  !First off, one computes the unscreened potential due to rho_in
  !One computes it a half grid point on the right, mainly to avoid things such as LOG(0)
  call full_v_array_wire_periodic(x-0.5*h,rho_in,V,n)
  V(n)=V(1) !need that because V(n) is not defined (there is a log(0))

  ! One computes the derivative of V at grid points using central finite difference with periodic BCs
  do i=2,n-1
     dV(i) = 1./h * (V(i)-V(i-1))
  end do
  dV(1) = 1./h * (V(1)-V(n-1)) ! because V(n) is out of bounds
  dV(n) = dV(1)

  aldV = alpha*dV

  ! now one computes the induced charge density at each point in e/ang, using periodic BCs

  do i=2,n-1
     old_rho(i) = 1./(2*h) * (aldV(i+1)-aldV(i-1))
  end do

  old_rho(1)=1./(2*h) * (aldV(2)-aldV(n-1))
  old_rho(n)=old_rho(1)

  ! change it to e/cm
  old_rho = old_rho*h ! e/ang
  old_rho = old_rho*1.E8 ! e/cm

  ! we start now the main iterative algorithm
  counter = 0
  subcounter = 0
  beta =0.5
  diff = 10000.
  conv = .TRUE.
  max_ind = MAXLOC(old_rho)

  do while (diff > 1.E-4)
     counter = counter +1
     subcounter = subcounter +1
     diff_old = diff

     !print *,counter, diff

     if (counter > max_iteration) then
        print *, "WARNING: recursive Poisson algorithm does not converge fast enough"
        conv = .FALSE.
        EXIT
     end if

     ! update the potential including polarization charges
     call full_v_array_wire_periodic(x-0.5*h,rho_in+old_rho,V,n)
     V(n) = V(1)

     !doing the same operations as before
     do i=2,n-1
        dV(i) = 1./h * (V(i)-V(i-1))
     end do
     dV(1) = 1./h * (V(1)-V(n-1)) ! because V(n) is out of bonds
     dV(n) = dV(1)

     aldV = alpha*dV

     do i=2,n-1
        new_rho(i) = 1./(2*h) * (aldV(i+1)-aldV(i-1))
     end do

     new_rho(1)=1./(2*h) * (aldV(2)-aldV(n-1))
     new_rho(n)=new_rho(1)

     ! need rho in e/cm
     new_rho = new_rho*h ! e/ang
     new_rho = new_rho*1.E8 ! e/cm

     indicator(MOD(counter,2)+1) = old_rho(max_ind(1))-new_rho(max_ind(1))

     if (indicator(1)*indicator(2) < 0) then ! there is an oscillation in the convergence
        beta = beta/1.5
        new_rho = 0.5*(new_rho+old_rho)
        subcounter = 0
     end if

     if (subcounter > 3) then
        beta = beta*2
        subcounter = 0
        if (beta>1.) then
           beta = 1.
        end if
     end if

     diff = ABS(MAXVAL(old_rho-new_rho))/ABS(MAXVAL(rho_in))

     old_rho = beta*new_rho + (1.-beta)*old_rho

  end do

  ! need to return a value of the potential defined on grid points, use linear interpolation
  do i=2,n
     potential(i) = 0.5*(V(i)+V(i-1))
  end do

  potential(1) = potential(n) ! periodic BCs
  rho_out = old_rho+rho_in ! total charge density

  ! convergence check
  call full_v_array_wire_periodic(x-0.5*h,rho_in+old_rho,V,n)
  V(n) = V(1)
  !doing the same operations as before
  do i=2,n
     dV(i) = 1./h * (V(i)-V(i-1))
  end do
  dV(1) = 1./h * (V(1)-V(n-1)) ! because V(n) is out of bonds
  dV(n) = dV(1)

  aldV = alpha*dV

  do i=2,n-1
     new_rho(i) = 1./(2*h) * (aldV(i+1)-aldV(i-1))
  end do

  new_rho(1)=1./(2*h) * (aldV(2)-aldV(n-1))
  new_rho(n)=new_rho(1)

  ! need rho in e/cm
  new_rho = new_rho*h ! e/ang
  new_rho = new_rho*1.E8 ! e/cm

  if (conv .eqv. .TRUE.) then
     !print *, "Recursive Poisson algorithm converged in", counter, "steps."
     !print *, "Convergence check:", ABS(MAXVAL(old_rho-new_rho))/ABS(MAXVAL(rho_in))
  else
     print *, "Recursive Poisson algorithm could not converge after", max_iteration, "steps."
  end if

end subroutine periodic_recursive_poisson


! This code may (or may not) be part of the MPAS distribution,
! So it is not protected by the DART copyright agreement.
!
! DART $Id$

  module get_coeff_mod

  use types_mod, only : r8
  use utilities_mod, only : error_handler, E_ERR

  implicit none

  private
  save
  public :: mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

  character(len=256) :: string1

  contains

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Purpose: Compute interpolation coefficients in 3D that can be used to
  !  interpolate a number of vector functions at a given locations. This is useful
  !  if the interpolation location does not change with time, or if several
  !  fields are to be interpolated at a given time step.  (If both the vector fields
  !  and the interpolation locations vary with time, there is no clear advantage in
  !  using either this method or the method for 2D interpoaltion above; for simplicity
  !  and because we foresee more uses for the method of this subroutine, we have not
  !  implemented a 3D version of the fixed field, variable interpolation location method
  !  as we have in 2D.) Coefficients are produced for handling Dirichlet boundary
  !  conditions (or no boundaries).  The interpolation is performed with basis functions
  !  that are RBFs plus a constant.
  ! Input:
  !  pointCount - the number of "source" points and functionValues supplied
  !  sourcePoints - the location of the "source" points in the 3D space where the values of
  !    the function are known.  The sourcePoints are projected into the plane given by
  !    planeBasisVectors
  !  unitVectors - the unit vectors associated with each of the sourcePoints.  Interpolation
  !    is performed by supplying the value of the vector function dotted into each of these unit
  !    vectors.  If multiple unit vectors are supplied at the same sourcePoint, they *must* be
  !    orthogonal for the interpolation to succeed.  The unitVectors are projected into the
  !    plane given by planeBasisVectors
  !  destinationPoint - the point where the interpolation will be performed.  The destinationPoint
  !    is projected into the plane given by planeBasisVectors
  !  alpha - a constant that give the characteristic length scale of the RBFs,
  !    should be on the order of the distance between points
  !  planeBasisVectors - the basis fectors for the plane where interpolation is performed.
  !    All points are projected into this plane.
  ! Output:
  !  coefficients - the coefficients used to interpolate a function with Dirichlet
  !    boundary conditions to the specified destinationPoint
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs(pointCount, &
    sourcePoints, unitVectors, destinationPoint, &
    alpha, planeBasisVectors, coefficients)

    integer, intent(in) :: pointCount
    real(kind=r8), dimension(pointCount,3), intent(in) :: sourcePoints
    real(kind=r8), dimension(pointCount,3), intent(in) :: unitVectors
    real(kind=r8), dimension(3), intent(in) :: destinationPoint
    real(kind=r8), intent(in) :: alpha
    real(kind=r8), dimension(2,3) :: planeBasisVectors
    real(kind=r8), dimension(pointCount, 3), intent(out) :: coefficients

    integer :: i, j
    integer :: matrixSize

    real(kind=r8) :: rSquared, rbfValue, unitVectorDotProduct

    real(kind=r8), dimension(pointCount,2) :: planarSourcePoints
    real(kind=r8), dimension(pointCount,2) :: planarUnitVectors
    real(kind=r8), dimension(2) :: planarDestinationPoint

    real(kind=r8), dimension(:,:), pointer :: matrix, submatrix, matrixCopy
    real(kind=r8), dimension(:,:), pointer :: rhs, subrhs, coeffs
    integer, dimension(:), pointer :: pivotIndices

    matrixSize = pointCount+2 ! space for constant vector in plane

    allocate(matrix(matrixSize,matrixSize))
    allocate(submatrix(pointCount,pointCount))
    allocate(matrixCopy(matrixSize,matrixSize))
    allocate(rhs(matrixSize,2))
    allocate(subrhs(pointCount,2))
    allocate(coeffs(matrixSize,2))
    allocate(pivotIndices(matrixSize))

    matrix = 0.0
    submatrix = 0.0
    rhs = 0.0
    subrhs = 0.0
    coeffs = 0.0

    do i = 1, pointCount
      planarSourcePoints(i,1) = sum(sourcePoints(i,:)*planeBasisVectors(1,:))
      planarSourcePoints(i,2) = sum(sourcePoints(i,:)*planeBasisVectors(2,:))
      planarUnitVectors(i,1) = sum(unitVectors(i,:)*planeBasisVectors(1,:))
      planarUnitVectors(i,2) = sum(unitVectors(i,:)*planeBasisVectors(2,:))
    end do
    planarDestinationPoint(1) = sum(destinationPoint*planeBasisVectors(1,:))
    planarDestinationPoint(2) = sum(destinationPoint*planeBasisVectors(2,:))

    call mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs(pointCount, 2, &
      planarSourcePoints, planarUnitVectors, planarDestinationPoint, &
      alpha, submatrix, subrhs)

    matrix(1:pointCount,1:pointCount) = submatrix
    rhs(1:pointCount,:) = subrhs

    do i = 1, pointCount
      matrix(i,pointCount+1:pointCount+2) = planarUnitVectors(i,:)
      matrix(pointCount+1:pointCount+2,i) = matrix(i,pointCount+1:pointCount+2)
    end do
    do i = 1,2
      rhs(pointCount+i,i) = 1.0 ! the unit vector in the ith direction
    end do

    ! solve each linear system
    matrixCopy = matrix
    call mpas_legs(matrix, matrixSize, rhs(:,1), coeffs(:,1), pivotIndices)
    call mpas_legs(matrixCopy, matrixSize, rhs(:,2), coeffs(:,2), pivotIndices)

    do i = 1,3
      coefficients(:,i) = planeBasisVectors(1,i)*coeffs(1:pointCount,1) &
        + planeBasisVectors(2,i)*coeffs(1:pointCount,2)
    end do

    deallocate(matrix)
    deallocate(submatrix)
    deallocate(matrixCopy)
    deallocate(rhs)
    deallocate(subrhs)
    deallocate(coeffs)
    deallocate(pivotIndices)

  end subroutine mpas_rbf_interp_func_3D_plane_vec_const_dir_comp_coeffs

  subroutine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs(pointCount, dimensions, &
    sourcePoints, unitVectors, destinationPoint, &
    alpha, matrix, rhs)

    integer, intent(in) :: pointCount, dimensions
    real(kind=r8), dimension(pointCount,dimensions), intent(in) :: sourcePoints
    real(kind=r8), dimension(pointCount,dimensions), intent(in) :: unitVectors
    real(kind=r8), dimension(dimensions), intent(in) :: destinationPoint
    real(kind=r8), intent(in) :: alpha
    real(kind=r8), dimension(pointCount,pointCount), intent(out) :: matrix
    real(kind=r8), dimension(pointCount,dimensions), intent(out) :: rhs

    integer :: i, j

    real(kind=r8) :: rSquared, rbfValue, unitVectorDotProduct

    do j = 1, pointCount
      do i = j, pointCount
        rSquared = sum((sourcePoints(i,:)-sourcePoints(j,:))**2)/alpha**2
        rbfValue = evaluate_rbf(rSquared)
        unitVectorDotProduct = sum(unitVectors(i,:)*unitVectors(j,:))
        matrix(i,j) = rbfValue*unitVectorDotProduct
        matrix(j,i) = matrix(i,j)
      end do
    end do

    do j = 1, pointCount
      rSquared = sum((destinationPoint-sourcePoints(j,:))**2)/alpha**2
      rhs(j,:) = evaluate_rbf(rSquared)*unitVectors(j,:)
    end do

  end subroutine mpas_set_up_vector_dirichlet_rbf_matrix_and_rhs

subroutine mpas_legs (A,N,B,X,INDX)
!
! subroutine to solve the equation A(N,N)*X(N) = B(N) with the
! partial-pivoting Gaussian elimination scheme.
! Copyright (c) Tao Pang 2001.
!
  IMPLICIT NONE
  integer, INTENT (IN) :: N
  integer :: I,J
  integer, INTENT (OUT), DIMENSION (N) :: INDX
  real(kind=r8), INTENT (INOUT), DIMENSION (N,N) :: A
  real(kind=r8), INTENT (INOUT), DIMENSION (N) :: B
  real(kind=r8), INTENT (OUT), DIMENSION (N) :: X
!
  CALL elgs (A,N,INDX)
!
  DO I = 1, N-1
    DO J = I+1, N
      B(INDX(J)) = B(INDX(J))-A(INDX(J),I)*B(INDX(I))
    END DO
  END DO
!
  X(N) = B(INDX(N))/A(INDX(N),N)
  DO I = N-1, 1, -1
    X(I) = B(INDX(I))
    DO J = I+1, N
      X(I) = X(I)-A(INDX(I),J)*X(J)
    END DO
    X(I) =  X(I)/A(INDX(I),I)
  END DO
!
END subroutine mpas_legs

function evaluate_rbf(rSquared) result(rbfValue)
  real(kind=r8), intent(in) :: rSquared
  real(kind=r8) :: rbfValue

  ! inverse multiquadratic
  rbfValue = 1/sqrt(1 + rSquared)

end function evaluate_rbf

subroutine elgs (A,N,INDX)
!
! subroutine to perform the partial-pivoting Gaussian elimination.
! A(N,N) is the original matrix in the input and transformed matrix
! plus the pivoting element ratios below the diagonal in the output.
! INDX(N) records the pivoting order.  Copyright (c) Tao Pang 2001.
!
  IMPLICIT NONE
  integer, INTENT (IN) :: N
  integer :: I,J,K,ITMP
  integer, INTENT (OUT), DIMENSION (N) :: INDX
  real(kind=r8) :: C1,PI,PI1,PJ
  real(kind=r8), INTENT (INOUT), DIMENSION (N,N) :: A
  real(kind=r8), DIMENSION (N) :: C
!
! Initialize the index
!
  DO I = 1, N
    INDX(I) = I
  END DO
!
! Find the rescaling factors, one from each row
!
  DO I = 1, N
    C1= 0.0
    DO J = 1, N
      !C1 = AMAX1(C1,ABS(A(I,J)))
      C1 = MAX(C1,ABS(A(I,J)))
    END DO
    C(I) = C1
  END DO
!
! Search the pivoting (largest) element from each column
!
  DO J = 1, N-1
    PI1 = 0.0
    K = 0
    DO I = J, N
      PI = ABS(A(INDX(I),J))/C(INDX(I))
      IF (PI.GT.PI1) THEN
        PI1 = PI
        K   = I
      ENDIF
    END DO
! This should never happen, but just in case:
    IF (K == 0) THEN
      write(string1,*)'K was never initialized!'
      call error_handler(E_ERR,'elgs',string1,source,revision,revdate)
    ENDIF

!
! Interchange the rows via INDX(N) to record pivoting order
!
    ITMP    = INDX(J)
    INDX(J) = INDX(K)
    INDX(K) = ITMP
    DO I = J+1, N
      PJ  = A(INDX(I),J)/A(INDX(J),J)
!
! Record pivoting ratios below the diagonal
!
      A(INDX(I),J) = PJ
!
! Modify other elements accordingly
!
      DO K = J+1, N
        A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
      END DO
    END DO
  END DO
!
END subroutine elgs

end module get_coeff_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!*************************************************
! module
!	QRDEC(z,y,detl,n1,n,m,u,lb,j1,ind)
!	RINV(x,y,z,n1,m,ind)
!
!	no common
!*************************************************

module mod_qrdec

	implicit none

contains
!=========
subroutine QRDEC(z_lc,y_lc,detl,n1,n,m,u,lb,j1,ind)

	implicit none

	integer, intent(in) :: n1, n, m, ind
	real(8), intent(inout) :: z_lc(n1,m), y_lc(n)
	integer, intent(out) :: lb(m), j1
	real(8), intent(out) :: detl, u(n)

	integer :: i, k, kk
	real(8) :: esp, sm, b, sl

	esp = 1.d-50!12
	detl = 0.d0
	j1 = 1

	do k = 1, m

		lb(k) = 0
		sm = 0.d0

		do i = j1, n
			u(i) = z_lc(i,k)
			sm = sm + z_lc(i,k) * z_lc(i,k)
		end do

		b = dsqrt(sm)

		if(b < esp) write(*,*)k,b,sm
		if(b < esp) cycle
		if(u(j1) > 0.d0) b = -b

		u(j1) = u(j1) - b

		do kk = k+1, m
			sl = 0.d0

			do i = j1, n
				sl = sl + z_lc(i,kk) * u(i)
			end do
			sl = sl / u(j1) / b
			do i = j1, n
				z_lc(i,kk) = z_lc(i,kk) + u(i) * sl
			end do

		end do

		z_lc(j1,k) = b
		detl = detl + dlog(dabs(b))

		if(ind /= 0) then
			sl = 0.d0
			do i = j1, n
				sl = sl + y_lc(i) * u(i)
			end do
			sl = sl / u(j1) / b
			do i = j1, n
				y_lc(i) = y_lc(i) + u(i) * sl
			end do
		end if

		lb(k) = j1
		j1 = j1 + 1

!	write(*,*)j1
	end do

	j1 = j1 - 1

return
end subroutine QRDEC

!==========
subroutine RINV(x_lc, y_lc, z_lc, n1, m, ind)

	implicit none

	integer, intent(in) :: n1, m, ind
	real(8), intent(in) :: y_lc(m), z_lc(n1,m)
	real(8), intent(inout) :: x_lc(m)

	integer :: k, k2
	real(8) :: uf

	if(ind == 0) then
		do k = m, 1, -1
			uf = y_lc(k)
			do k2 = k+1, m
				uf = uf - x_lc(k2) * z_lc(k,k2)
			end do
			x_lc(k) = uf / z_lc(k,k)
		end do
		return
	end if

	do k = ind, m
		uf = y_lc(k)
		do k2 = ind, k-1
			uf = uf - x_lc(k2) * z_lc(k2,k)
		end do
		x_lc(k) = uf / z_lc(k,k)
	end do

return
end subroutine RINV

end module mod_qrdec


module boysfunc
implicit none
include "boysfunc_data1.h"
contains
    subroutine initboys()
        ! ================================================
include "boysfunc_data2.h"
    end subroutine
    ! Best way to calculate Boys function.
    function boys(x,n)
        real*8 :: boys
        real*8,intent(in) :: x
        integer,intent(in) :: n
        integer :: idx1,idx2,idx3,idx4,idx5
        real*8 :: x1,x2,x3,x4,x5
        real*8 :: y1,y2,y3,y4,y5
        real*8 :: y12,y23,y34,y45
        real*8 :: y123,y234,y345
        real*8 :: y1234,y2345
        ! ================================================
        ! Accurate method.
        if (n > MaxN) then
            boys = accboys(x,n)
        else
            ! Asympotic approximation.
            if (x > AsymX) then
                boys = BoysAsympoticConstants(n+1)*(x**(-n-0.5))
            ! Fast method.
            else
                ! Look up.
                idx1 = x*100+1; x1 = (idx1-1)/100.0; y1 = BoysTable(idx1,n+1)
                idx2 = idx1+1; x2 = x1+dX1; y2 = BoysTable(idx2,n+1)
                idx3 = idx1+2; x3 = x1+dX2; y3 = BoysTable(idx3,n+1)
                idx4 = idx1+3; x4 = x1+dX3; y4 = BoysTable(idx4,n+1)
                idx5 = idx1+4; x5 = x1+dX4; y5 = BoysTable(idx5,n+1)
                ! Neville interpolation.
                y12 = (x-x2)*(y1-y2)/(x1-x2)+y2
                y23 = (x-x3)*(y2-y3)/(x2-x3)+y3
                y34 = (x-x4)*(y3-y4)/(x3-x4)+y4
                y45 = (x-x5)*(y4-y5)/(x4-x5)+y5
                y123 =(x-x3)*(y12-y23)/(x1-x3)+y23
                y234 =(x-x4)*(y23-y34)/(x2-x4)+y34
                y345 =(x-x5)*(y34-y45)/(x3-x5)+y45
                y1234 = (x-x4)*(y123-y234)/(x1-x4)+y234
                y2345 = (x-x5)*(y234-y345)/(x2-x5)+y345
                boys = (x-x5)*(y1234-y2345)/(x1-x5)+y2345
            endif
        endif
    end function
    ! Calculate Boys function accurately but SLOWLY.
    function accboys(x,n)
        real*8 :: accboys
        real*8,intent(in) :: x
        integer,intent(in) :: n
        integer,parameter :: NIt = 4
        real*8 :: tdts(NIt)
        real*8 :: tresults(NIt)
        integer :: ngs
        integer :: i,n2,j
        real*8 :: dt,t,tresult,tresult12,tresult23,tresult34,tresult123,tresult234
        ! ================================================
        n2 = n*2
        ngs = 25
        ! Naive grid integral.
        do i = 1,NIt
            ngs = ngs*4
            dt = 1./ngs
            if (n2 == 0) then
                tresult = 0.5
            else
                tresult = 0
            endif
            t = dt
            do j = 1,ngs
                tresult = tresult+exp(-x*t*t)*(t**n2)
                t = t+dt
            enddo
            tresult = tresult+exp(-x*t*t)*(t**n2)/2
            tresult = tresult*dt
            tdts(i) = dt
            tresults(i) = tresult
        enddo
        ! Neville extrapolation to zero step.
        tresult12 = (-tdts(2))*(tresults(1)-tresults(2))/(tdts(1)-tdts(2))+tresults(2)
        tresult23 = (-tdts(3))*(tresults(2)-tresults(3))/(tdts(2)-tdts(3))+tresults(3)
        tresult34 = (-tdts(4))*(tresults(3)-tresults(4))/(tdts(3)-tdts(4))+tresults(4)
        tresult123 = (-tdts(3))*(tresult12-tresult23)/(tdts(1)-tdts(3))+tresult23
        tresult234 = (-tdts(4))*(tresult23-tresult34)/(tdts(2)-tdts(4))+tresult34
        accboys = (-tdts(4))*(tresult123-tresult234)/(tdts(1)-tdts(4))+tresult234
    end function
end module


*> \brief \b SQRT05
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SQRT05(M,N,L,NB,RESULT)
*
*       .. Scalar Arguments ..
*       INTEGER LWORK, M, N, L, NB, LDT
*       .. Return values ..
*       REAL RESULT(6)
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SQRT05 tests STPQRT and STPMQRT.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          Number of rows in lower part of the test matrix.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          Number of columns in test matrix.
*> \endverbatim
*>
*> \param[in] L
*> \verbatim
*>          L is INTEGER
*>          The number of rows of the upper trapezoidal part the
*>          lower test matrix.  0 <= L <= M.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*>          NB is INTEGER
*>          Block size of test matrix.  NB <= N.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL array, dimension (6)
*>          Results of each of the six tests below.
*>
*>          RESULT(1) = | A - Q R |
*>          RESULT(2) = | I - Q^H Q |
*>          RESULT(3) = | Q C - Q C |
*>          RESULT(4) = | Q^H C - Q^H C |
*>          RESULT(5) = | C Q - C Q |
*>          RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SQRT05(M,N,L,NB,RESULT)
      IMPLICIT NONE
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER LWORK, M, N, L, NB, LDT
*     .. Return values ..
      REAL RESULT(6)
*
*  =====================================================================
*
*     ..
*     .. Local allocatable arrays
      REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
     $  R(:,:), RWORK(:), WORK( : ), T(:,:),
     $  CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
*
*     .. Parameters ..
      REAL ZERO, ONE
      PARAMETER( ZERO = 0.0, ONE = 1.0 )
*     ..
*     .. Local Scalars ..
      INTEGER INFO, J, K, M2, NP1
      REAL   ANORM, EPS, RESID, CNORM, DNORM
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 )
*     ..
*     .. External Subroutine ..
      EXTERNAL SGEMM, SLARNV, STPMQRT, STPQRT, SGEMQRT, SSYRK, SLACPY,
     $         SLASET
*     ..
*     .. External Functions ..
      REAL SLAMCH
      REAL SLANGE, SLANSY
      LOGICAL  LSAME
      EXTERNAL SLAMCH, SLANGE, SLANSY, LSAME
*     ..
*     .. Data statements ..
      DATA ISEED / 1988, 1989, 1990, 1991 /
*
      EPS = SLAMCH( 'Epsilon' )
      K = N
      M2 = M+N
      IF( M.GT.0 ) THEN
         NP1 = N+1
      ELSE
         NP1 = 1
      END IF
      LWORK = M2*M2*NB
*
*     Dynamically allocate all arrays
*
      ALLOCATE(A(M2,N),AF(M2,N),Q(M2,M2),R(M2,M2),RWORK(M2),
     $           WORK(LWORK),T(NB,N),C(M2,N),CF(M2,N),
     $           D(N,M2),DF(N,M2) )
*
*     Put random stuff into A
*
      LDT=NB
      CALL SLASET( 'Full', M2, N, ZERO, ZERO, A, M2 )
      CALL SLASET( 'Full', NB, N, ZERO, ZERO, T, NB )
      DO J=1,N
         CALL SLARNV( 2, ISEED, J, A( 1, J ) )
      END DO
      IF( M.GT.0 ) THEN
         DO J=1,N
            CALL SLARNV( 2, ISEED, M-L, A( N+1, J ) )
         END DO
      END IF
      IF( L.GT.0 ) THEN
         DO J=1,N
            CALL SLARNV( 2, ISEED, MIN(J,L), A( N+M-L+1, J ) )
         END DO
      END IF
*
*     Copy the matrix A to the array AF.
*
      CALL SLACPY( 'Full', M2, N, A, M2, AF, M2 )
*
*     Factor the matrix A in the array AF.
*
      CALL STPQRT( M,N,L,NB,AF,M2,AF(NP1,1),M2,T,LDT,WORK,INFO)
*
*     Generate the (M+N)-by-(M+N) matrix Q by applying H to I
*
      CALL SLASET( 'Full', M2, M2, ZERO, ONE, Q, M2 )
      CALL SGEMQRT( 'R', 'N', M2, M2, K, NB, AF, M2, T, LDT, Q, M2,
     $              WORK, INFO )
*
*     Copy R
*
      CALL SLASET( 'Full', M2, N, ZERO, ZERO, R, M2 )
      CALL SLACPY( 'Upper', M2, N, AF, M2, R, M2 )
*
*     Compute |R - Q'*A| / |A| and store in RESULT(1)
*
      CALL SGEMM( 'T', 'N', M2, N, M2, -ONE, Q, M2, A, M2, ONE, R, M2 )
      ANORM = SLANGE( '1', M2, N, A, M2, RWORK )
      RESID = SLANGE( '1', M2, N, R, M2, RWORK )
      IF( ANORM.GT.ZERO ) THEN
         RESULT( 1 ) = RESID / (EPS*ANORM*MAX(1,M2))
      ELSE
         RESULT( 1 ) = ZERO
      END IF
*
*     Compute |I - Q'*Q| and store in RESULT(2)
*
      CALL SLASET( 'Full', M2, M2, ZERO, ONE, R, M2 )
      CALL SSYRK( 'U', 'C', M2, M2, -ONE, Q, M2, ONE,
     $            R, M2 )
      RESID = SLANSY( '1', 'Upper', M2, R, M2, RWORK )
      RESULT( 2 ) = RESID / (EPS*MAX(1,M2))
*
*     Generate random m-by-n matrix C and a copy CF
*
      DO J=1,N
         CALL SLARNV( 2, ISEED, M2, C( 1, J ) )
      END DO
      CNORM = SLANGE( '1', M2, N, C, M2, RWORK)
      CALL SLACPY( 'Full', M2, N, C, M2, CF, M2 )
*
*     Apply Q to C as Q*C
*
      CALL STPMQRT( 'L','N', M,N,K,L,NB,AF(NP1,1),M2,T,LDT,CF,
     $ M2,CF(NP1,1),M2,WORK,INFO)
*
*     Compute |Q*C - Q*C| / |C|
*
      CALL SGEMM( 'N', 'N', M2, N, M2, -ONE, Q,M2,C,M2,ONE,CF,M2)
      RESID = SLANGE( '1', M2, N, CF, M2, RWORK )
      IF( CNORM.GT.ZERO ) THEN
         RESULT( 3 ) = RESID / (EPS*MAX(1,M2)*CNORM)
      ELSE
         RESULT( 3 ) = ZERO
      END IF
*
*     Copy C into CF again
*
      CALL SLACPY( 'Full', M2, N, C, M2, CF, M2 )
*
*     Apply Q to C as QT*C
*
      CALL STPMQRT('L','T',M,N,K,L,NB,AF(NP1,1),M2,T,LDT,CF,M2,
     $              CF(NP1,1),M2,WORK,INFO)
*
*     Compute |QT*C - QT*C| / |C|
*
      CALL SGEMM('T','N',M2,N,M2,-ONE,Q,M2,C,M2,ONE,CF,M2)
      RESID = SLANGE( '1', M2, N, CF, M2, RWORK )
      IF( CNORM.GT.ZERO ) THEN
         RESULT( 4 ) = RESID / (EPS*MAX(1,M2)*CNORM)
      ELSE
         RESULT( 4 ) = ZERO
      END IF
*
*     Generate random n-by-m matrix D and a copy DF
*
      DO J=1,M2
         CALL SLARNV( 2, ISEED, N, D( 1, J ) )
      END DO
      DNORM = SLANGE( '1', N, M2, D, N, RWORK)
      CALL SLACPY( 'Full', N, M2, D, N, DF, N )
*
*     Apply Q to D as D*Q
*
      CALL STPMQRT('R','N',N,M,N,L,NB,AF(NP1,1),M2,T,LDT,DF,N,
     $             DF(1,NP1),N,WORK,INFO)
*
*     Compute |D*Q - D*Q| / |D|
*
      CALL SGEMM('N','N',N,M2,M2,-ONE,D,N,Q,M2,ONE,DF,N)
      RESID = SLANGE('1',N, M2,DF,N,RWORK )
      IF( CNORM.GT.ZERO ) THEN
         RESULT( 5 ) = RESID / (EPS*MAX(1,M2)*DNORM)
      ELSE
         RESULT( 5 ) = ZERO
      END IF
*
*     Copy D into DF again
*
      CALL SLACPY('Full',N,M2,D,N,DF,N )
*
*     Apply Q to D as D*QT
*
      CALL STPMQRT('R','T',N,M,N,L,NB,AF(NP1,1),M2,T,LDT,DF,N,
     $             DF(1,NP1),N,WORK,INFO)

*
*     Compute |D*QT - D*QT| / |D|
*
      CALL SGEMM( 'N', 'T', N, M2, M2, -ONE, D, N, Q, M2, ONE, DF, N )
      RESID = SLANGE( '1', N, M2, DF, N, RWORK )
      IF( CNORM.GT.ZERO ) THEN
         RESULT( 6 ) = RESID / (EPS*MAX(1,M2)*DNORM)
      ELSE
         RESULT( 6 ) = ZERO
      END IF
*
*     Deallocate all arrays
*
      DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
      RETURN
      END


program problem20
  implicit none
  integer, parameter       :: m=10 ! 640 bits should be enough
  integer*16, dimension(m) :: n
  integer                  :: i

  ! initialize number
  n(1)=1
  do i=2,m
     n(i)=0
  end do

  do i=1,100
     call multiply(n,i)
  end do

  print *, n
  print *, sum_of_digits(n)

contains
  ! not suitable for large factors
  subroutine multiply(n,f)
    integer*16, dimension(m) :: n
    integer                  :: f,i
    integer*16, parameter    :: mask=lshift(1_16,64)-1

    do i=1,m
       n(i)=n(i)*f
       if (i > 1) then
          n(i)=n(i)+rshift(n(i-1),64)
          n(i-1)=iand(n(i-1),mask)
       end if
    end do
  end subroutine multiply

  ! return sum of digits of n.  destroys n.
  function sum_of_digits(n)
    implicit none
    integer*16, dimension(m) :: n
    integer                  :: sum_of_digits

    sum_of_digits=0
    do while (sum(n) > 0)
       do i=m,1,-1
          if (i > 1) then
             n(i-1)=shiftl(mod(n(i),10),64)+n(i-1)    ! carry
          else
             sum_of_digits=sum_of_digits+mod(n(i),10) ! tally
          end if
          n(i)=n(i)/10
       end do
    end do
  end function sum_of_digits

end program problem20


      FUNCTION BINT(I,J,A,B,IV,IW,R,Z)
      DIMENSION  R(1) , Z(1)
      BINT = 0.0
      IW1 = IW + 1
      C1P = B
      C2P = A
      C1 = C1P
       C2 = C2P
      AW = 0.0
      IF( R(I) .NE. 0.0E0 .AND. R(J) .NE. 0.0E0 ) AW = ALOG(R(J)/R(I))
      DO 100 IT = 1,IW1
      IC = IW - IT + 1
      IF (IC.EQ.0) C1 = 1.0
      IF (IT.EQ.1) C2 = 1.0
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C THE FOLLOWING CODE REPLACES REAL FUNCTION COEF
C
      IF(IT.EQ.1) GO TO 20
      IN = 1
      ID = 1
      DO 10 K=2,IT
      IN = IN*(IW-K+2)
      ID = ID*(K-1)
   10 CONTINUE
      COEF = IN/ID
      GO TO 30
   20 COEF = 1.0
   30 CONTINUE
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C THE FOLLOWING CODE REPLACES REAL FUNCTION AJ
C
      IS1 = IC+IV+1
      IF(IS1.EQ.0) GO TO 60
      SP1 = IS1
      AJ = (R(J)**IS1-R(I)**IS1) / SP1
      GO TO 70
   60 AJ = AW
   70 CONTINUE
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      BINT = BINT + C1 ** IC * AJ * C2 ** (IT - 1) * COEF
      C1 = C1P
      C2 = C2P
  100 CONTINUE
      AW = IW
      BINT = BINT / AW
      RETURN
      END


module pde

  use global_module

  implicit none

  integer, parameter :: Neq = 5 ! Number of equations

  real(kind=8), parameter :: M      = 5.3136d-26   ! [kg] molecular mass
  real(kind=8), parameter :: gam    = 1.4          ! adiabatic constant (diatomic molecule, roto-translation only)
  real(kind=8), parameter :: th_vib = 2256.0d0     ! [K]  vibrational temperature
  real(kind=8), parameter :: a_MW   = 138.0d0      ! O2, parameter for the Millikan-White model
  real(kind=8), parameter :: b_MW   = 0.03d0       ! O2, parameter for the Millikan-White model

  real(kind=8), parameter :: kB  = 1.38d-23              ! [J/K] Boltzmann constant
  real(kind=8), parameter :: PI  = 4.0d0*DATAN(1.0d0)

  ! Name of primitive variables, used ONLY for exporting the solution to VTK file
  ! NOTE: To initialize it here, all entries need to have the same length!!!
  !       I'm using three letters for simplicity.
  character(len=20), dimension(Neq) :: prim_names = (/'rho','UUx','UUy','Ttr','Tvv'/)

  contains

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

  subroutine initialize_solution(U)

    implicit none

    real(kind=8), dimension(:,:,:), intent(inout) :: U

    integer      :: i, j

    ! Initialize internal cells (i = "1,2" and "Nx-1, Nx" are ghost cells. Same thing for j)
    U(1, 3:Nx-2, 3:Ny-2) = rho0     ! Density
    U(2, 3:Nx-2, 3:Ny-2) = rho0*ux0 ! Momentum along x
    U(3, 3:Nx-2, 3:Ny-2) = rho0*uy0 ! Momentum along y
    U(4, 3:Nx-2, 3:Ny-2) = rho0*(ux0**2 + uy0**2)/2.0 + rho0*compute_e_int(T0,T0) ! total energy
    U(5, 3:Nx-2, 3:Ny-2) = rho0*compute_e_vib(T0) ! vibrational energy

  end subroutine

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

  subroutine assign_BCs(U)

    implicit none

    real(kind=8), dimension(:,:,:), intent(inout) :: U

    integer :: i, j

    ! ----- LEFT BC (x_min, whatever y) --------

    U(1, 1:2, :) = rho0     ! Density
    U(2, 1:2, :) = rho0*ux0 ! Momentum along x
    U(3, 1:2, :) = rho0*uy0 ! Momentum along y
    U(4, 1:2, :) = rho0*(ux0**2 + uy0**2)/2.0 + rho0*compute_e_int(T0,T0) ! total energy
    U(5, 1:2, :) = rho0*compute_e_vib(T0) ! vibrational energy

    ! ----- RIGHT BC (x_max, whatever y) --------

    U(1, Nx-1:Nx, :) = rho0     ! Density
    U(2, Nx-1:Nx, :) = rho0*ux0 ! Momentum along x
    U(3, Nx-1:Nx, :) = rho0*uy0 ! Momentum along y
    U(4, Nx-1:Nx, :) = rho0*(ux0**2 + uy0**2)/2.0 + rho0*compute_e_int(T0,T0) ! total energy
    U(5, Nx-1:Nx, :) = rho0*compute_e_vib(T0) ! vibrational energy

    ! ----- BOTTOM BC (y_min, whatever x) --------

    U(1, :, 1:2) = rho0     ! Density
    U(2, :, 1:2) = rho0*ux0 ! Momentum along x
    U(3, :, 1:2) = rho0*uy0 ! Momentum along y
    U(4, :, 1:2) = rho0*(ux0**2 + uy0**2)/2.0 + rho0*compute_e_int(T0,T0) ! total energy
    U(5, :, 1:2) = rho0*compute_e_vib(T0) ! vibrational energy

    ! ----- TOP BC (y_max, whatever x) --------

    U(1, :, Ny-1:Ny) = rho0     ! Density
    U(2, :, Ny-1:Ny) = rho0*ux0 ! Momentum along x
    U(3, :, Ny-1:Ny) = rho0*uy0 ! Momentum along y
    U(4, :, Ny-1:Ny) = rho0*(ux0**2 + uy0**2)/2.0 + rho0*compute_e_int(T0,T0) ! total energy
    U(5, :, Ny-1:Ny) = rho0*compute_e_vib(T0) ! vibrational energy

  end subroutine

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

  subroutine compute_primitive_from_conserved(U, prim)

    ! Computes vector of primitive variables "prim" from the conserved variables "U"

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: prim

    ! Working variables
    real(kind=8) :: rho, ux, uy, T, Tv, e_int, e_vib, e_rt

    ! Extract primitive variables
    rho = U(1)
    ux  = U(2)/(rho + 1.0d-25) ! Use a small tolerance, since rho may be zero
    uy  = U(3)/(rho + 1.0d-25) ! Use a small tolerance, since rho may be zero

    e_int = U(4)/(rho + 1.0d-25) - (ux*ux + uy*uy)/2.0 ! Internal energy [J/kg]
    e_vib = U(5)/(rho + 1.0d-25) ! Vibrational energy [J/kg]

    e_rt  = e_int - e_vib  ! Roto-translational energy [J/kg]

    T  = 2.0/5.0*e_rt*M/kB ! Roto-translational temperature
    Tv = th_vib/log(kB*th_vib/(M*e_vib)+1) ! Vibrational temperature

    ! Compose array of primitive variables
    prim(1) = rho
    prim(2) = ux
    prim(3) = uy
    prim(4) = T
    prim(5) = Tv

  end subroutine

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

  subroutine compute_flux_ws_x(U, Fx, ws_max, ws_min)

    ! Computes the convective flux along x,
    ! and also the maximum and minimum wave speeds (required by some numerical flux schemes)

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: Fx
    real(kind=8), intent(out) :: ws_max, ws_min

    real(kind=8), dimension(Neq) :: prim
    real(kind=8) :: rho, ux, uy, T, Tv, P, rhoE, e_rt, e_vib

    ! Compute primitive variables
    call compute_primitive_from_conserved(U, prim)
    rho = prim(1)
    ux  = prim(2)
    uy  = prim(3)
    T   = prim(4)
    Tv  = prim(5)

    P     = rho*kB/M*T ! Compute pressure, P = n*kB*T

    e_rt  = compute_e_rt(T)   ! [J/kg]
    e_vib = compute_e_vib(Tv) ! [J/kg]

    rhoE  = rho*(ux*ux + uy*uy)/2.0 + rho*(e_rt + e_vib) ! Total energy

    ! Assemble fluxes Fx
    Fx(1) = rho*ux
    Fx(2) = rho*ux*ux + P
    Fx(3) = rho*ux*uy
    Fx(4) = rhoE*ux + P*ux
    Fx(5) = rho*e_vib*ux

    ! Maximum and minimum wave speeds (eigenvalues of the Euler system)

    ws_max = ux + sqrt(gam*P/rho)
    ws_min = ux - sqrt(gam*P/rho)

  end subroutine

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

  subroutine compute_flux_ws_y(U, Fy, ws_max, ws_min)

    ! Computes the convective flux along y,
    ! and also the maximum and minimum wave speeds (required by some numerical flux schemes)

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: Fy
    real(kind=8), intent(out) :: ws_max, ws_min

    real(kind=8), dimension(Neq) :: prim
    real(kind=8) :: rho, ux, uy, T, Tv, P, rhoE, e_rt, e_vib

    ! Compute primitive variables
    call compute_primitive_from_conserved(U, prim)
    rho = prim(1)
    ux  = prim(2)
    uy  = prim(3)
    T   = prim(4)
    Tv  = prim(5)

    P     = rho*kB/M*T ! Compute pressure, P = n*kB*T

    e_rt  = compute_e_rt(T)   ! [J/kg]
    e_vib = compute_e_vib(Tv) ! [J/kg]

    rhoE  = rho*(ux*ux + uy*uy)/2.0 + rho*(e_rt + e_vib)

    ! Assemble fluxes Fy
    Fy(1) = rho*uy
    Fy(2) = rho*ux*uy
    Fy(3) = rho*uy*uy + P
    Fy(4) = rhoE*uy + P*uy
    Fy(5) = rho*e_vib*uy

    ! Maximum and minimum wave speeds (eigenvalues of the Euler system)

    ws_max = uy + sqrt(gam*P/rho)
    ws_min = uy - sqrt(gam*P/rho)

  end subroutine

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

  function compute_e_int(T_tr, T_vib)

    ! Internal energy for diatomic molecule with rotational and vibrational DOFs (RRHO model)

    implicit none

    real(kind=8), intent(in) :: T_tr, T_vib

    real(kind=8) :: compute_e_int

    compute_e_int = compute_e_rt(T_tr) + compute_e_vib(T_vib) ! [J/kg]

    return

  end function

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

  function compute_e_rt(T_tr)

    ! Roto-vibrational energy for diatomic molecule (Rigid Rotor model)

    implicit none

    real(kind=8), intent(in) :: T_tr

    real(kind=8) :: compute_e_rt

    compute_e_rt = kB/M*5.0/2.0*T_tr ! [J/kg]

    return

  end function

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

  function compute_e_vib(T_vib)

    ! Vibrational energy for diatomic molecule (RRHO model)

    implicit none

    real(kind=8), intent(in) :: T_vib

    real(kind=8) :: compute_e_vib
    real(kind=8) :: T

    T = abs(T_vib + 0.00001d0) ! [K] add a small tolerance, and make it positive (to prevent integration errors)
    compute_e_vib = kB/M*th_vib/(exp(th_vib/T) - 1.0) ! [J/kg]

    return

  end function

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

  function compute_cv_int(T_tr, T_vib)

    ! Specific heat for diatomic molecule with rotational and vibrational DOFs (RRHO model)

    implicit none

    real(kind=8), intent(in) :: T_tr, T_vib

    real(kind=8) :: compute_cv_int

    real(kind=8) :: T_vib_tol

    T_vib_TOL = abs(T_vib + 0.001d0) ! [K] add a small tolerance, and make it positive (to prevent integration errors)
    compute_cv_int = kB/M*(5.0/2.0 + &
    (th_vib/T_vib_tol)**2.0*exp(th_vib/T_vib_tol)/(exp(th_vib/T_vib_tol) - 1.0)**2.0 ) ! [J/(kg K)]

    return

  end function

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

  subroutine compute_Teq_from_e_int(e_int, Teq)

    ! This subroutine finds the equilibrium temperature T that gives the internal energy e_int,
    ! using Newton iterations (cv_int is the derivative of e_int).

    implicit none

    real(kind=8), intent(in)  :: e_int
    real(kind=8), intent(out) :: Teq

    real(kind=8) :: error ! Error in the temperature
    real(kind=8) :: T_new

    ! ---- NEWTON METHOD ----
    ! Initialize Teq using the rigid rotor model without vibration

    Teq = 2.0/5.0*e_int*M/kB

    error = 1.0d0

    do while ( error .gt. 0.0000001d0 )
      T_new = Teq - (compute_e_int(Teq,Teq) - e_int)/(compute_cv_int(Teq,Teq) + 0.0001d0)
      error = abs(T_new - Teq)
      Teq   = T_new
    end do

  end subroutine

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

  subroutine compute_tau_vib(n, T, tau_v)

    ! Computes the vibrational relaxation time.

    implicit none

    real(kind=8), intent(in)  :: n, T  ! Input:  number density [1/m^3], and temperature [K]
    real(kind=8), intent(out) :: tau_v    ! Output: vibraitonal relaxation time [s]

    real(kind=8) :: P
    real(kind=8) :: tau_MW, tau_P, SIG

    P = n*kB*T

    ! Compute relaxation time from Millikan & White
    tau_MW = 1.0/(P*101325.0)*exp(a_MW*(T**(-1.0/3.0) - b_MW) - 18.42)

    ! Compute Park correction
    SIG    = 3.0d-21*(50000.0/T)**2 ! Estimation of the vibrational relaxation cross-section
    tau_P  = 1.0/(n*sqrt(8.0*kB*T/PI/M)*SIG)

    ! Vibrational relaxation time
    tau_v = tau_MW + tau_P

  end subroutine

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

  subroutine compute_source_term(U, S, tau_v, e_vib_eq, e_vib)

    ! Computes collisional relaxation source term

    implicit none

    real(kind=8), dimension(Neq), intent(in)  :: U
    real(kind=8), dimension(Neq), intent(out) :: S
    real(kind=8), intent(out) :: tau_v, e_vib_eq, e_vib

    real(kind=8), dimension(Neq) :: prim

    real(kind=8) :: n, T_tr, T_vib, T_eq, e_int

    ! Compute primitive variables
    call compute_primitive_from_conserved(U, prim)

    n     = prim(1)/M ! number density n = rho/M
    T_tr  = prim(4)
    T_vib = prim(5)

    ! Vibrational and internal energy at this step
    e_vib = compute_e_vib(T_vib)
    e_int = compute_e_rt(T_tr) + e_vib

    call compute_tau_vib(n, T_tr, tau_v) ! Relaxation rate

    call compute_Teq_from_e_int(e_int, T_eq) ! Compute equilibrium temperature

    e_vib_eq = compute_e_vib(T_eq) ! Vibrational energy at equilibrium

    ! Assemble source term
    S = 0.0 ! Init

    S(5) = prim(1)*(e_vib_eq - e_vib)/tau_v

    ! print*, "tau_vib, e_vib_eq, e_vib: ", tau_v, e_vib_eq, e_vib

  end subroutine

end module


      SUBROUTINE DG01NY( INDI, N, XR, XI )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     Auxiliary routine called only by DG01ND.
C
C     For efficiency, no tests of the input scalar parameters are
C     performed.
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF, ONE, TWO, EIGHT
      PARAMETER         ( ZERO=0.0D0, HALF=0.5D0, ONE = 1.0D0,
     $                    TWO=2.0D0, EIGHT=8.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         INDI
      INTEGER           N
C     .. Array Arguments ..
      DOUBLE PRECISION  XI(*), XR(*)
C     .. Local Scalars ..
      LOGICAL           LINDI
      INTEGER           I, J, N2
      DOUBLE PRECISION  AI, AR, BI, BR, HELPI, HELPR, PI2, WHELP, WI,
     $                  WR, WSTPI, WSTPR
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. Intrinsic Functions ..
      INTRINSIC         ATAN, DBLE, SIN
C     .. Executable Statements ..
C
      LINDI = LSAME( INDI, 'D' )
C
C     Initialisation.
C
      PI2 = EIGHT*ATAN( ONE )
      IF ( LINDI ) PI2 = -PI2
C
      WHELP = PI2/DBLE( 2*N )
      WSTPI = SIN( WHELP )
      WHELP = SIN( HALF*WHELP )
      WSTPR = -TWO*WHELP*WHELP
      WI = ZERO
C
      IF ( LINDI ) THEN
         WR = ONE
         XR(N+1) = XR(1)
         XI(N+1) = XI(1)
      ELSE
         WR = -ONE
      END IF
C
C     Recursion.
C
      N2 = N/2 + 1
      DO 10 I = 1, N2
         J = N + 2 - I
         AR = XR(I) + XR(J)
         AI = XI(I) - XI(J)
         BR = XI(I) + XI(J)
         BI = XR(J) - XR(I)
         IF ( LINDI ) THEN
            AR = HALF*AR
            AI = HALF*AI
            BR = HALF*BR
            BI = HALF*BI
         END IF
         HELPR = WR*BR - WI*BI
         HELPI = WR*BI + WI*BR
         XR(I) = AR + HELPR
         XI(I) = AI + HELPI
         XR(J) = AR - HELPR
         XI(J) = HELPI - AI
         WHELP = WR
         WR = WR + WR*WSTPR - WI*WSTPI
         WI = WI + WI*WSTPR + WHELP*WSTPI
   10 CONTINUE
C
      RETURN
C *** Last line of DG01NY ***
      END


subroutine DIFCO(nq, nz, mubar_z, T, den, edd, &
                 hscale, tauedd, DK, H_atm, bx1x2, scale_H)
  use photochem_data, only: grav_z, mass
  implicit none

  integer, intent(in) :: nq, nz
  real(8), intent(in) :: mubar_z(nz), T(nz), den(nz), edd(nz)

  real(8), intent(out) :: hscale(nz), tauedd(nz), DK(nz)
  real(8), intent(out) :: H_atm(nz)
  real(8), intent(out) :: bx1x2(nq,nz)
  real(8), intent(out) :: scale_H(nq,nz)

  ! local variables
  real*8 bkmg, eddav, denav
  real*8 h, tav
  integer i,j

  ! ***** DK(I) = K*N AT GRID STEP I+1/2 *****
  DO i = 1 , nz - 1
    eddav = SQRT(EDD(i)*EDD(i+1))
                                 !average eddy diffusion in grid center
    denav = SQRT(DEN(i)*DEN(i+1))
                               !average density at grid center
    DK(i) = eddav*denav
  ENDDO
  !
  !   COMPUTE DIFFUSION LIFETIME AT EACH HEIGHT (H*H/K)
  DO i = 1 , nz
    bkmg = 1.38E-16/(1.67E-24*mubar_z(i)*grav_z(i))
    h = bkmg*T(i)
    HSCALE(i) = h
    TAUEDD(i) = h*h/EDD(i)
  ENDDO

  DO i = 1 , nz - 1
    bkmg = 1.38E-16/(1.67E-24*mubar_z(i)*grav_z(i))
    tav = SQRT(T(i)*T(i+1)) !average temperature at grid center
    H_ATM(i) = bkmg*tav
    !  compute scale heights of all the species in the atmosphere at all
    !   heights
    DO j = 1 , nq
      SCALE_H(j,i) = bkmg*tav*mubar_z(i)/MASS(j)
    ENDDO
    do j = 1,nq
      bx1x2(j,i) = 1.52d18*(1.d0/mass(j)+1.d0/mubar_z(i))**0.5d0*(tav**0.5)
    enddo

  ENDDO

  ! top layer of atmosphere
  bkmg = 1.38E-16/(1.67E-24*mubar_z(nz)*grav_z(nz))
  H_ATM(nz) = bkmg*tav
  DO j = 1 , nq
     SCALE_H(j,nz) = bkmg*T(nz)*mubar_z(nz)/MASS(j)
  ENDDO
  do j = 1,nq
    bx1x2(j,NZ) = 1.52d18*(1.d0/mass(j)+1.d0/mubar_z(nz))**0.5d0*(T(nz)**0.5d0)
  enddo

end subroutine


!> Interfaces of the integrals used in the particle-wall interactions
!! for a Lennard-Jones particle inside a cylindrical cavity. The walls
!! of the cavity consist of smoothly and evenly distributed LJ
!! particles.
module cylinder_integrals

interface
   function ljwall_tensor(k, radiusA, densityA, epsilonratio, &
        sigmaratio, powers, isotropic_coeffs, anisotropy_coeffs) &
        result(local_tensor)
     use num_kind, only: dp
     implicit none
     real(dp), intent(in) :: k, radiusA, densityA, epsilonratio, sigmaratio
     integer, intent(in) :: powers(:)
     real(dp), intent(in), optional :: isotropic_coeffs(:)
     real(dp), intent(in), optional :: anisotropy_coeffs(:)
     real(dp) :: local_tensor(3, 3)
   end function ljwall_tensor
end interface

interface
   !> Computes numerically the integral I_m(k, R), k = r/R, in the paper
   !! X. Zhang, W. Wang, and G. Jiang, Fluid Phase Equilibria 2004,
   !! 218(2), 239-246.
   pure function zhangI(m, k, rc)
     use num_kind, only: dp
     implicit none
     integer, intent(in) :: m
     real(dp), intent(in) :: k, rc
     real(dp) :: zhangI
   end function zhangI
end interface

interface
   !> Computes numerically the derivative d I_m(k, R) / d k of the
   !! integral I_m(k, R), k = r/R, in the paper X. Zhang, W. Wang, and
   !! G. Jiang, Fluid Phase Equilibria 2004, 218(2), 239-246.
   pure function d_zhangI(m, k, rc)
     use num_kind, only: dp
     implicit none
     integer, intent(in) :: m
     real(dp), intent(in) :: k, rc
     real(dp) :: d_zhangI
   end function d_zhangI
end interface

interface
   !> Computes numerically the value of the Hypergeometric function
   !! _2F_1(a, b, c, z), as defined in the Handbook of Mathematical
   !! Functions (1972) by Abramovitz and Stegun.
   real(c_double) pure function hyp2f1(a, b, c, z) bind(C, name='hyp2f1')
     use, intrinsic :: iso_c_binding
     real(c_double), intent(in), value :: a, b, c, z
   end function hyp2f1
end interface

interface
   !> Computes the value of the gamma function at @p x.
   real(c_double) pure function gamma(x) bind(C, name='gamma')
     use, intrinsic :: iso_c_binding
     real(c_double), intent(in), value :: x
   end function gamma
end interface

end module


   module modis_numerical_module

implicit none

private

public :: bisectionsearch, linearinterpolation, linearinterpolation_3d, bilinear_interpolation, BisectionSimple

contains

SUBROUTINE BisectionSimple(theta,thetaArray,ntheta,iAngLow, iAngHi)

		INTEGER,INTENT(IN)::ntheta
		REAL,INTENT(IN)::theta,thetaArray(1:ntheta)
		INTEGER,INTENT(OUT)::iAngLow, iAngHi

		INTEGER:: iAng

		iAngLow = 1
		iAngHi = ntheta

		DO
			IF((iAngHi - iAngLow) == 1)EXIT
			iAng = (iAngHi + iAngLow)/2
			IF(thetaArray(iAng) < theta)THEN
				iAngLow = iAng
			ELSE
				iAngHi = iAng
			ENDIF
		ENDDO

		if (iAngLow < 1) iAngLow = 1
		if (ianghi < 1) ianghi = 1
		if (iAngHi > ntheta) iAngHi = ntheta
		if (ianglow > ntheta) ianglow = ntheta

END SUBROUTINE BisectionSimple

! currently bisectionsearch works for ascending arrays only
subroutine bisectionsearch(xx,x,jlo,jhi)

IMPLICIT NONE
INTEGER, INTENT(INOUT) :: jlo, jhi
REAL, INTENT(IN) :: x
REAL, DIMENSION(:), INTENT(IN) :: xx
INTEGER :: n,inc,jm
LOGICAL :: ascnd
n=size(xx)
ascnd = (xx(n) >= xx(1))
if (jlo <= 0 .or. jlo > n) then
   jlo=0
   jhi=n+1
else
   inc=1
   if (x >= xx(jlo) .eqv. ascnd) then
      do
         jhi=jlo+inc
         if (jhi > n) then
            jhi=n+1
            exit
         else
            if (x < xx(jhi) .eqv. ascnd) exit
            jlo=jhi
            inc=inc+inc
         end if
      end do
   else
      jhi=jlo
      do
         jlo=jhi-inc
         if (jlo < 1) then
            jlo=0
            exit
         else
            if (x >= xx(jlo) .eqv. ascnd) exit
            jhi=jlo
            inc=inc+inc
         end if
      end do
   end if
end if
do
   if (jhi-jlo <= 1) then
!     NOTE: the following two lines assume that the xx array MUST have been sorted in ascending order for this to work as designed
      if (x >= xx(n)) jlo=n-1
      if (x <= xx(1)) jlo=1
      exit
   else
      jm=(jhi+jlo)/2
      if (x >= xx(jm) .eqv. ascnd) then
         jlo=jm
      else
         jhi=jm
      end if
   end if
end do

! G.Wind 12.16.05 inserted logic to make sure that the values can not go outside
! the valid array bounds
if (jlo < 1) jlo = 1
if (jlo > n) jlo = n
if (jhi < 1) jhi = 1
if (jhi > n) jhi = n

end subroutine bisectionsearch

logical function real_s_equal(x,y)
   real :: x, y
   real_s_equal = (abs(x-y) <= epsilon(x))
end function real_s_equal

logical function realsingle_s_equal(x,y)
   real :: x, y
   realsingle_s_equal = (abs(x-y) <= epsilon(x))
end function realsingle_s_equal

subroutine realsingle_s_where_equal(x,y)
   real ,intent(inout) :: x(:)
   real :: y

   where( abs(x - y) <= epsilon(y) )
      x = 1.
   elsewhere
      x = 0.
   endwhere

end subroutine realsingle_s_where_equal

real function linearinterpolation(X,Y,XX)

!       XX    R     Interpolation POINT
!       X   R(NN)   INDEPENDENT VARIABLE
!       Y   R(NN)   DEPENDENT   VARIABLE
!
!       Written by
!        Mark A Gray
!        SM&A SSG .
!        Code 913, NASA/GSFC
!        Greenbelt, MD 20771

   implicit none

   real, intent(in)  ::   X(2), xx
   real, intent(in)  ::   y(2)

   if (realsingle_s_equal(x(1),x(2))) then
     LinearInterpolation = y(1)
     return
   elseif(realsingle_s_equal(x(1),xx)) then
     LinearInterpolation = y(1)
     return
   elseif (realsingle_s_equal(x(2),xx)) then
     LinearInterpolation = y(2)
     return
   else
     LinearInterpolation = y(1) + ( ( xx - x(1) ) / ( x(2) - x(1)) ) * ( y(2) -y(1) )
   endif

end function linearinterpolation

real function bilinear_interpolation( X, Y, XX, YY, source, method )

	implicit none

	real, dimension(2), intent(in) :: X, Y
	real, intent(in) :: XX, YY
	integer, intent(in) :: method
	real, dimension(:,:), intent(in) :: source

	real :: mid1, mid2

	real :: area1, area2, area3, area4
	real :: deltaX1, deltaX2, deltaY1, deltaY2

	real :: num1, num2

	if (method == 1) then

		deltaX1 = X(1) - XX
		deltaX2 = X(2) - XX

		deltaY1 = Y(1) - YY
		deltaY2 = Y(2) - YY

		area1 = abs(deltaX1 * deltaY1)
		area2 = abs(deltaX2 * deltaY1)
		area3 = abs(deltaX1 * deltaY2)
		area4 = abs(deltaX2 * deltaY2)

		num2 = area1 + area2 + area3 + area4

		num1 = source(2, 2) * area1 + &
			source(1, 1) * area4 + &
			source(1, 2) * area2 + &
			source(2, 1) * area3

		bilinear_interpolation = num1 / num2
	else

		mid1 = linearinterpolation(X, (/source(1,1), source(1,2)/) , XX)
		mid2 = linearinterpolation(X, (/source(2,1), source(2,2)/) , XX)

		bilinear_interpolation = linearinterpolation(Y, (/mid1, mid2/), YY)
	endif

end function bilinear_interpolation

real function LinearInterpolation_3d(index_theta01,index_theta02,  &
                                       index_theta1, index_theta2,  &
                                       index_phi1,   index_phi2,&
                                       theta,theta0,phi,&
                                       theta_grid,  &
                                       theta0_grid,&
                                       phi_grid,&
                                       debug, &
                                       reflectance)

!Description:
!       Performa a linear interpolation within a 3d grid for a defined
!       point bounded by defined points.
!
!Input parameters:
!
!Output parameters:
!
!Revision history:
!
!Team-unique header:
!
!References and credits:
!    written by; Mark Gray
!

   implicit none

   integer, intent(in)  :: index_theta1, index_theta2, index_phi1,index_phi2, &
                           index_theta01, index_theta02

   real, intent(in)     :: reflectance(:,:,:)
   real, intent(in)     :: theta_grid(:), &
                             theta0_grid(:),phi_grid(:),theta,theta0,phi

   logical, intent(in)    :: debug

   real                 :: corner1, corner2, corner3, corner4,  &
                                   corner5, corner6, corner7, corner8
   real                 :: volume1, volume2, volume3, volume4,  &
                                   volume5, volume6, volume7, volume8
   real                 :: num_1, num_2
   real                 :: theta0_val_1, theta0_val_2, theta_val_1, theta_val_2,phi_val_1, phi_val_2

   theta0_val_1 = theta0_grid(index_theta01)-theta0
   theta0_val_2 = theta0_grid(index_theta02)-theta0

   theta_val_1 = theta_grid(index_theta1)-theta
   theta_val_2 = theta_grid(index_theta2)-theta

   phi_val_1 = phi_grid(index_phi1)-phi
   phi_val_2 = phi_grid(index_phi2)-phi

   volume2= abs(theta0_val_1 * theta_val_1 * phi_val_2)
   volume3= abs(theta0_val_1 * theta_val_2 * phi_val_2)
   volume4= abs(theta0_val_1 * theta_val_2 * phi_val_1)
   volume5= abs(theta0_val_2 * theta_val_1 * phi_val_1)
   volume6= abs(theta0_val_2 * theta_val_1 * phi_val_2)
   volume7= abs(theta0_val_2 * theta_val_2 * phi_val_2)
   volume8= abs(theta0_val_2 * theta_val_2 * phi_val_1)
   volume1= abs(theta0_val_1 * theta_val_1 * phi_val_1)

   num_1 =     reflectance(index_theta01,index_theta1,index_phi1) * volume7 + &
               reflectance(index_theta01,index_theta1,index_phi2) * volume8 +  &
               reflectance(index_theta02,index_theta1,index_phi2) * volume4 +  &
               reflectance(index_theta02,index_theta1,index_phi1) * volume3 +  &
               reflectance(index_theta01,index_theta2,index_phi1) * volume6 +  &
               reflectance(index_theta01,index_theta2,index_phi2) * volume5 +  &
               reflectance(index_theta02,index_theta2,index_phi2) * volume1 +  &
               reflectance(index_theta02,index_theta2,index_phi1) * volume2

   num_2 =     volume1 + volume2 +  &
               volume3 + volume4 +  &
               volume5 + volume6 +  &
               volume7 + volume8

   LinearInterpolation_3d = num_1/num_2

end function LinearInterpolation_3d

end module modis_numerical_module


!!# MODULE <<LIB_RandomSubCellData>>
MODULE LIB_RandomSubcellData

!!## PURPOSE
!! Subroutines to generate random slices and random data on the slices:
!! * incoming angular fluxes and
!! * sources within the cell.

!!## MODULES
USE KND_IntrinsicTypes !!((01-A-KND_IntrinsicTypes.f90))
USE FUN_Random         !!((03-A-FUN_Random.f90))
USE FUN_Error          !!((04-A-FUN_Error.f90))

!!## DEFAULT IMPLICI
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PUBLIC ACCESS
PUBLIC :: RandomSlice
PUBLIC :: RandomData_PosLin
PUBLIC :: RandomData_PosPara

!!## MODULE PROCEDURES
CONTAINS

SUBROUTINE RandomSlice(ub,t1,t2,smin1,smin2,smax1,smax2)
REAL(KIND_Rdp),INTENT(IN) :: ub
REAL(KIND_Rdp),INTENT(OUT) :: smin1,smin2,smax1,smax2,t1,t2
REAL(KIND_Rdp) :: ds2,ds1,dt

ds1=Random((/0._KIND_Rdp,ub/))
ds2=Random((/0._KIND_Rdp,ub/))
dt=Random((/0._KIND_Rdp,ub/))
t1=Random((/-ub,ub/))
t2=t1+dt
smin1=Random((/-ub,ub/))
smax1=smin1+ds1
smax2=Random((/smin1,ub/))
smin2=smax2-ds2
END SUBROUTINE

SUBROUTINE RandomData_PosLin(ubsig,ubq,t1,t2,smin1,smin2,smax1,smax2,sigma,q1,qs,qt,sintheta)
REAL(KIND_Rdp),INTENT(IN) :: ubsig,ubq,t1,t2,smin1,smin2,smax1,smax2
REAL(KIND_Rdp),INTENT(OUT) :: sigma,q1,qs,qt,sintheta
REAL(KIND_Rdp) :: qt1,qt2,qs1,qs2,smin,smax
REAL(KIND_Rdp) :: qp1,qp2,qp3,qp4
REAL(KIND_Rdp) :: power

!!--begin--

!get power
power = LOG10(ubsig)
power = Random((/-power,power/))

!get sigma
sigma=10._KIND_Rdp**(power)
sigma=MAX(0._KIND_Rdp,sigma) !bound >=0

smax = MAX(smax2,smax1)
smin = MIN(smin2,smin1)

sintheta=Random((/-0.1_KIND_Rdp,1.1_KIND_Rdp/))
sintheta=MIN(Max(0.0_KIND_Rdp,sintheta),1.0_KIND_Rdp) !bound to [0,1]

33 CONTINUE

!create a completely positive random source
!constant
q1=Random((/0._KIND_Rdp,ubq/))

!t part
qt1=Random((/0._KIND_Rdp,ubq/))
qt2=Random((/0._KIND_Rdp,ubq/))
qt=(qt2-qt1)/(t2-t1)

!s part
qs1=Random((/0._KIND_Rdp,ubq/))
qs2=Random((/0._KIND_Rdp,ubq/))
qs=(qs2-qs1)/(smax-smin)

!q(s,t) = qs*(s-smin) + qt*(t-t1) + q1
!modify source
q1=q1 - t1*qt - smin*qs

!calculate four points
qp1 = q1+qt*t1+qs*smin1
qp2 = q1+qt*t2+qs*smin2
qp3 = q1+qt*t2+qs*smax2
qp4 = q1+qt*t1+qs*smax1
IF( ANY((/qp1,qp2,qp3,qp4/)<0._KIND_Rdp) )THEN
 GOTO 33
END IF

!!--end--
END SUBROUTINE

SUBROUTINE RandomData_PosPara(ubsig,ubq,t1,t2,smin1,smin2,smax1,smax2,sigma,c,b,a,sintheta)
REAL(KIND_Rdp),INTENT(IN) :: ubsig,ubq,t1,t2,smin1,smin2,smax1,smax2
REAL(KIND_Rdp),INTENT(OUT) :: sigma,c,b,a,sintheta
REAL(KIND_Rdp) :: smin,smax
REAL(KIND_Rdp) :: Extrema,LenEdge
REAL(KIND_Rdp) :: Psi1,Psi2,PsiAvg,PsiEdge(3),PsiInOut(3)
LOGICAL        :: HasExtrema
REAL(KIND_Rdp) :: power

!!--begin--

!get power
power = LOG10(ubsig)
power = Random((/-power,power/))

!get sigma
sigma=10._KIND_Rdp**(power)
sigma=MAX(0._KIND_Rdp,sigma) !bound >=0

smax = MAX(smax2,smax1)
smin = MIN(smin2,smin1)

sintheta=Random((/-0.1_KIND_Rdp,1.1_KIND_Rdp/))
sintheta=MIN(Max(0.0_KIND_Rdp,sintheta),1.0_KIND_Rdp) !bound to [0,1]

34 CONTINUE

Psi1     = Random((/0._KIND_Rdp,ubq/))
Psi2     = Random((/0._KIND_Rdp,ubq/))
PsiAvg   = Random((/Psi1,Psi2/))
LenEdge  = SQRT( (t2-t1)**2 + (smin2-smin1)**2 )
PsiEdge  = PsiEdge_from_2Pt1Avg( PsiAvg , LenEdge , &
                                 Psi1 , Psi2 , &
                                 HasExtrema , Extrema )
! WRITE(*,*)"-----"
! WRITE(*,*)"Psi1=",Psi1
! WRITE(*,*)"Psi2=",Psi2
! WRITE(*,*)"PsiAvg=",PsiAvg
! WRITE(*,*)"LenEdge=",LenEdge
! WRITE(*,*)"PsiEdge=",PsiEdge
! WRITE(*,*)"HasExtrema=",HasExtrema
! WRITE(*,*)"Extrema=",Extrema
! WRITE(*,*)"-----"

IF( HasExtrema )THEN
 GOTO 34
END IF

PsiInOut = PsiInOut_from_PsiEdge( PsiEdge , LenEdge , (/t1,t2/) , &
                                  PsiAvg )
c = PsiInOut(1)
b = PsiInOut(2)
a = PsiInOut(3)
Extrema = (-b/(2*a)) + t1

! WRITE(*,*)"-----"
! WRITE(*,*)"c=",c
! WRITE(*,*)"b=",b
! WRITE(*,*)"a=",a
! WRITE(*,*)"Extrema=",Extrema
! WRITE(*,*)"t1=",t1
! WRITE(*,*)"t2=",t2
! WRITE(*,*)"-----"

IF( Extrema>t1 .AND. Extrema<t2 )THEN
 35 CONTINUE
 !can debug here if desired
END IF

!!--end--
END SUBROUTINE

!!### FUNCTION <<PsiEdge_from_2Pt1Avg>>
FUNCTION PsiEdge_from_2Pt1Avg( PsiAvg , LenEdge , &
  Psi1 , Psi2 , HasExtrema , Extrema ) RESULT(PsiEdge)

!!#### PURPOSE
!! Convert 3 values of the outgoing edge to a parabolic function.

!!#### REQUIRED INPUT
!! * the average over an outgoing edge <PsiAvg>
!! * the length of the edge $L=$<LenEdge>
!! * the point values at the left and right <Psi1> and <Psi2>
REAL(KIND_Rdp),INTENT(IN) :: PsiAvg
REAL(KIND_Rdp),INTENT(IN) :: LenEdge
REAL(KIND_Rdp),INTENT(IN) :: Psi1
REAL(KIND_Rdp),INTENT(IN) :: Psi2

!!#### REQUIRED OUTPUT
!! * the 1D parabolic edge function for $\ell \in [0,L]$
!      PsiEdge(1) + PsiEdge(2) * \ell + PsiEdge(3) * \ell**2
REAL(KIND_Rdp) :: PsiEdge(3)

!!#### OPTIONAL OUTPUT
!! * whether or not there is an extrema in the region
LOGICAL       ,INTENT(OUT),OPTIONAL :: HasExtrema
REAL(KIND_Rdp),INTENT(OUT),OPTIONAL :: Extrema

!!#### LOCAL VARIABLES
REAL(KIND_Rdp) :: Extrema_

!!--begin--

IF( PRESENT(Extrema) )THEN
 Extrema = Error(Extrema)
END IF

!parabolic interpolant
PsiEdge(3) = ( 3*Psi1 - 6*PsiAvg + 3*Psi2 )/LenEdge**2
PsiEdge(2) = (-4*Psi1 + 6*PsiAvg - 2*Psi2 )/LenEdge
PsiEdge(1) = Psi1

IF( PRESENT(HasExtrema) )THEN
 Extrema_ = -PsiEdge(2)/(2*PsiEdge(3))
 HasExtrema = Extrema_>0._KIND_Rdp .AND. Extrema_<LenEdge
 IF( PRESENT(Extrema) )THEN
  IF( HasExtrema )THEN
   Extrema = Extrema_
  END IF
 END IF
END IF

!!--end--
END FUNCTION

!!### FUNCTION <<PsiInOut_from_PsiEdge>>
FUNCTION PsiInOut_from_PsiEdge( PsiEdge , LenEdge , T , &
  PsiAvg ) RESULT(PsiInOut)

!!#### PURPOSE
!! Convert a parabolic function representation on an edge ($\ell$
!! coordinates) to the slice edge ($t$ coordinates).

!!#### DETAILS
!! The conversion centers around the following expression
!!
!! $$ \ell(t) = \frac{t-T_1}{T_2-T_1} L      \quad \ell \in [0,L] $$
!!
!! and the inverse
!!
!! $$ t(\ell) = T_1 + \frac{\ell}{L} (T_2-T_1) \quad t \in [T_1,T_2]. $$
!!
!! This $T_1$ and $T_2$ are not the same as the $t_1$ and $t_2$
!! that form the bounds for a slice.  These are for a whole edge.

!!#### REQUIRED INPUT
!! * the 1D parabolic edge function for $\ell \in [0,L]$
!      PsiEdge(1) + PsiEdge(2) * l + PsiEdge(3)* l**2
!! * the length of the edge $L=$<LenEdge>
!! * the t-bounds of the EDGE (not slice)
REAL(KIND_Rdp),INTENT(IN) :: PsiEdge(3)
REAL(KIND_Rdp),INTENT(IN) :: LenEdge
REAL(KIND_Rdp),INTENT(IN) :: T(2)
REAL(KIND_Rdp),INTENT(IN) :: PsiAvg

!!#### REQUIRED OUTPUT
!! * the 1D parabolic edge function for $t \in [t1,t2]$
!      PsiInOut(1) + PsiInOut(2) * t + PsiInOut(3) * t**2
REAL(KIND_Rdp) :: PsiInOut(3)

!!#### LOCAL VARIABLES
REAL(KIND_Rdp) :: Dt,LdivDt1,LdivDt2,Lm
INTEGER :: i

!!--begin--

!get some convenience variables
Dt = T(2) - T(1)

!set the output
IF( Dt<1.E-10_KIND_Rdp )THEN
 PsiInOut(1) = PsiAvg
 PsiInOut(2) = 0._KIND_Rdp
 PsiInOut(3) = 0._KIND_Rdp
ELSE
 LdivDt1 = LenEdge/Dt
 LdivDt2 = LdivDt1**2
 PsiInOut(1) = PsiEdge(1) - (T(1))*PsiEdge(2)*LdivDt1 +   (T(1)**2)*PsiEdge(3)*LdivDt2
 PsiInOut(2) =                     PsiEdge(2)*LdivDt1 - 2*(T(1)   )*PsiEdge(3)*LdivDt2
 PsiInOut(3) =                                                      PsiEdge(3)*LdivDt2
END IF

!!--end--
END FUNCTION

END MODULE


program test_hyp2f1
use, intrinsic :: iso_c_binding
implicit none

interface
   real(c_double) function hyp2f1(a, b, c, z) bind(C, name='hyp2f1')
     use, intrinsic :: iso_c_binding
     real(c_double), value :: a, b, c, z
   end function hyp2f1
end interface

integer, parameter :: n_m = 14
real(c_double) :: a, b, c, z, y, loss
integer :: m = 4, n = 100, i, j
integer :: ms(n_m)
ms(1:2) = [4, 10]
ms(3:n_m) = [(j, j = 11, 11 + n_m - 3)]

c = 1
write(*, '("# hyp2f1(-(m - 1) / 2, -(m - 3) / 2, 1, z^2)")')
write(*, '("#",2(' // fmt_char_dp() //', 1X))') '', " m =" // repeat(' ', fmt_char_dp_len() - 2)
write(*, '(' // fmt_char_dp() // ')', advance='no') "# z" // repeat(' ', fmt_char_dp_len() - 2)

do i = 1, n_m
   write(*, '(", "' // fmt_char_dp() // ')', advance='no') ms(i)
end do
write(*, '(/)', advance='no')

do i = 0, n - 1
  z = i * 1.0 / n
  write(*, '(' // fmt_char_dp() // ')', advance='no') z
  do j = 1, n_m
     a = -(ms(j) - 1) / 2.0
     b = a + 1
     if (mod(ms(j), 2) == 0) then
        y = hyp2f1(a, b, c, z**2)
     else
        !y = hyp2f1_negint(-(ms(j) - 1) / 2, 1, z**2)
        y = hyp2f1_negint(-(ms(j) - 1) / 2, -(ms(j) - 3) / 2, 1, z**2)
     end if
     write(*, '(", "' // fmt_char_dp() // ')', advance='no') y
  end do
  write(*, '(/)', advance='no')
end do

contains

!! Computes the value of the Gauss hypergeometric function in the special case
!! in which a is a negative integer, b = a + 1 and c is integer, c <= a or
!! c > 0. In this case, the hypergeometric is a finite polynomial of order
!! -b = -a - 1.
!!
function hyp2f1_negint(a, b, c, z) result(sum)
  integer, intent(in) :: a, b, c
  real(c_double), intent(in) :: z
  real(c_double) :: term, sum
  integer(c_int) :: n
  integer :: i

  if (a < 0) n = -a
  if (b < 0 .and. b > a) n = -b

  sum = coeff(a, b, c, n)
  do i = n - 1, 0, -1
     sum = sum * z + coeff(a, b, c, i)
  end do

end function

function coeff(a, b, c, n) result(res)
  integer, intent(in) :: a, b, c, n
  real(c_double) :: res
  if (n == 0) then
     res = 1.0
  else
     res = ph(a, n) / real(ph(c, n), c_double) * ph(b, n) / real(fact(n), c_double)
  end if
end function

recursive function ph(a, n) result(res)
  integer, intent(in) :: a, n
  integer :: res
  if (n == 0 ) then
     res = 1
  else
     res = a * ph(a + 1, n - 1)
  end if
end function

recursive function fact(n) result(res)
  integer, intent(in) :: n
  integer :: res
  if (n > 1) then
     res = n * fact(n - 1)
  else
     res = 1
  end if
end function

!> Returns a formatting character for a double precision real number. To be
!! used when consistent formatting of real numbers is needed.
!!
pure function fmt_char_dp() result(format_char)
  integer :: e
  integer :: w
  integer :: d
  real(c_double) :: u
  character(len = 50) :: w_char !! Width of field
  character(len = 50) :: d_char !! Width of decimal field
  character(len = 50) :: e_char !! width of exponent
  character(len = 50) :: format_char
  e = int(log10(real(range(u)))) + 1
  d = precision(u)
  w = 3 + d + 2 + e
  write(w_char, *) w
  write(e_char, *) e
  write(d_char, *) d
  write(format_char, *) 'G' // trim(adjustl(w_char)) // '.' // trim(adjustl(d_char)) // 'E' // trim(adjustl(e_char))
  format_char = trim(adjustl(format_char))
end function

pure function fmt_char_dp_len() result(w)
  integer :: e
  integer :: w
  integer :: d
  real(c_double) :: u
  character(len = 50) :: w_char !! Width of field
  character(len = 50) :: d_char !! Width of decimal field
  character(len = 50) :: e_char !! width of exponent
  character(len = 50) :: format_char
  e = int(log10(real(range(u)))) + 1
  d = precision(u)
  w = 3 + d + 2 + e
end function

end program