!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testExpTables
#include "UnitTest.h"
USE UnitTest
USE IntrType
USE ExceptionHandler
USE Allocs
USE ParameterLists
USE ExpTables

IMPLICIT NONE

TYPE(ExceptionHandlerType),TARGET :: e
REAL(SRK) :: x,ans,err(5),xtest,x1,x2,x3,y1,y2,y3
REAL(SRK) :: reftbl(-10000:0),reftbl2(-10000:0),reftbl3(-10000:0)
REAL(SRK) :: reftbl4(1:1000)
INTEGER(SIK) :: i
TYPE(ExpTableType),SAVE :: testET1,testET2(5)
TYPE(ParamType),SAVE :: PL
LOGICAL(SBK) :: bool

CREATE_TEST('Test ExpTables')

CALL e%setStopOnError(.FALSE.)
CALL e%setQuietMode(.TRUE.)
CALL eExpTable%addSurrogate(e)
CALL eParams%addSurrogate(e)

WRITE(*,*) '==================================================='
WRITE(*,*) 'TESTING EXPTABLES...'
WRITE(*,*) '==================================================='
WRITE(*,*) 'TESTING EXPONENTTABLETYPE'

!Error checking
CALL PL%clear()
CALL testET1%initialize(PL)
CALL PL%add('ExpTables -> tabletype',0)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> tabletype',2)
CALL PL%add('ExpTables -> minval',1)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> minval',-10)
CALL PL%add('ExpTables -> maxval',1)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> maxval',-10)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> maxval',0)
CALL PL%add('ExpTables -> nintervals',-1)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%set('ExpTables -> nintervals',100)
CALL PL%add('ExpTables -> errorflag',.TRUE.)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL PL%add('ExpTables -> error',0.005_SRK)
CALL testET1%clear()
CALL testET1%initialize(PL)
CALL testET1%initialize(PL)
CALL testET1%clear()
!For the coverage
CALL PL%set('ExpTables -> tabletype',5)
CALL PL%set('ExpTables -> nintervals',1000)
CALL PL%set('ExpTables -> error',1e-7_SRK)
CALL testET1%initialize(PL)
x=testET1%maxVal-0.5_SRK*testET1%dx
ans=testET1%EXPT(x)

CALL PL%set('ExpTables -> errorflag',.FALSE.)
CALL PL%remove('ExpTables -> error')
x=-1.234567891012_SRK
DO i=1,5
  CALL PL%set('ExpTables -> tabletype',i)
  CALL testET2(i)%initialize(PL)
  ans=EXPT(testET2(i),x)
  err(i)=ans-(1._SRK-exp(x))
ENDDO

!For exact exponent function
bool = (testET2(1)%isinit .OR. testET2(1)%tableType == 1 &
      .OR.testET2(1)%nintervals == -1 .OR. (testET2(1)%dx .APPROXEQ. 0._SRK) &
      .OR.(testET2(1)%dx2rd .APPROXEQ. 0._SRK) .OR. (testET2(1)%rdx .APPROXEQ. 0._SRK) &
      .OR.(testET2(1)%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET2(1)%minVal == 0) &
      .OR.(testET2(1)%maxVal == 0) .OR. (testET2(1)%tableErr .APPROXEQ. 0._SRK))
ASSERT(bool, 'testET2(1)%initialize(...)')
WRITE(*,*) '  Passed: CALL testET2(1)%initialize(...) EXACT'
!For SINGLE_LEVEL_EXP_TABLE exponent function
bool = (testET2(2)%isinit .OR. testET2(2)%tableType == 2 &
      .OR. testET2(2)%nintervals == 1000 .OR. (testET2(2)%dx .APPROXEQ. 1.e-3_SRK) &
      .OR. (testET2(2)%dx2rd .APPROXEQ. 0._SRK) .OR. (testET2(2)%rdx .APPROXEQ. 1000._SRK) &
      .OR. (testET2(2)%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET2(2)%minVal == -10) &
      .OR. (testET2(2)%maxVal == 0) .OR. (testET2(2)%tableErr .APPROXEQ. 0.5e-3_SRK))
ASSERT(bool, 'testET2(2)%initialize(...)')
xtest=-10._SRK
DO i=-10000,0
  reftbl(i)=1._SRK-exp(xtest)
  xtest=xtest+1.e-3_SRK
  ASSERT(reftbl(i) .APPROXEQ. testET2(2)%table(i), 'testET2(2)%initialize(...)')
  FINFO() i
ENDDO
!Failed in intel release due to compiler optimizations
!  bool = (ALL(reftbl .APPROXEQ. testET2(2)%table))
!  ASSERT(bool, 'testET2(2)%initialize(...)')
WRITE(*,*) '  Passed: CALL testET2(2)%initialize(...) SINGLE_LEVEL'
!For TWO_LEVEL_EXP_TABLE exponent function
bool = (testET2(3)%isinit .OR. testET2(3)%tableType == 3 &
      .OR. testET2(3)%nintervals == 1000 .OR. (testET2(3)%dx .APPROXEQ. 1.e-3_SRK) &
      .OR. (testET2(3)%dx2rd .APPROXEQ. 1.e-6_SRK) .OR. (testET2(3)%rdx .APPROXEQ. 1000._SRK) &
      .OR. (testET2(3)%rdx2rd .APPROXEQ. 1.e6_SRK) .OR. (testET2(3)%minVal == -10) &
      .OR. (testET2(3)%maxVal == 0) .OR. (testET2(3)%tableErr .APPROXEQ. 0.5e-6_SRK))
ASSERT(bool, 'testET2(3)%initialize(...)')
xtest=-10._SRK
DO i=-10000,0
  reftbl(i)=exp(xtest)
  xtest=xtest+1.e-3_SRK
  ASSERT(reftbl(i) .APPROXEQ. testET2(3)%table(i), 'testET2(3)%initialize(...)')
  FINFO() i
ENDDO
!Failed in intel release due to compiler optimizations
!bool = (ALL(reftbl .APPROXEQ. testET2(3)%table))
!ASSERT(bool, 'testET2(3)%initialize(...)')
FINFO() testET2(3)%table
FINFO() reftbl
xtest=0._SRK
DO i=1,1000
  xtest=xtest+1.e-6_SRK
  reftbl4(i)=exp(xtest)
ENDDO
bool = (ALL(reftbl4 .APPROXEQ. testET2(3)%table2rd))
ASSERT(bool, 'testET2(3)%initialize(...)')
WRITE(*,*) '  Passed: CALL testET2(3)%initialize(...) TWO_LEVEL'
!For LINEAR_EXP_TABLE exponent function
bool = (testET2(4)%isinit .OR. testET2(4)%tableType == 4 &
      .OR. testET2(4)%nintervals == 1000 .OR. (testET2(4)%dx .APPROXEQ. 1.e-3_SRK) &
      .OR. (testET2(4)%dx2rd .APPROXEQ. 0._SRK) .OR. (testET2(4)%rdx .APPROXEQ. 1000._SRK) &
      .OR. (testET2(4)%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET2(4)%minVal == -10) &
      .OR. (testET2(4)%maxVal == 0) .OR. (testET2(4)%tableErr .APPROXEQ. 1.25e-7_SRK))
ASSERT(bool, 'testET2(4)%initialize(...)')
x1=-10._SRK
y1=1._SRK-EXP(x1)
DO i=-10000,0
  x2=x1+1e-3_SRK
  y2=1._SRK-EXP(x2)
  reftbl(i)=(y2-y1)*1000._SRK
  reftbl2(i)=y1-reftbl(i)*x1
  x1=x2
  y1=y2
ENDDO
DO i=-10000,0
  bool = (reftbl(i) .APPROXEQ. testET2(4)%table2D(1,i))
  ASSERT(bool, 'testET2(4)%initialize(...)')
  FINFO() i,reftbl(i),testET2(4)%table2D(1,i)
ENDDO
DO i=-10000,0
  bool = (reftbl2(i) .APPROXEQ. testET2(4)%table2D(2,i))
  ASSERT(bool, 'testET2(4)%initialize(...)')
  FINFO() i,reftbl2(i),testET2(4)%table2D(2,i)
ENDDO
WRITE(*,*) '  Passed: CALL testET2(4)%initialize(...) LINEAR'

!For ORDER2_EXP_TABLE exponent function
bool = (testET2(5)%isinit .OR. testET2(5)%tableType == 5 &
      .OR. testET2(5)%nintervals == 1000 .OR. (testET2(5)%dx .APPROXEQ. 1.e-3_SRK) &
      .OR. (testET2(5)%dx2rd .APPROXEQ. 0._SRK) .OR. (testET2(5)%rdx .APPROXEQ. 1000._SRK) &
      .OR. (testET2(5)%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET2(5)%minVal == -10) &
      .OR. (testET2(5)%tableErr .APPROXEQ. 9.630017699314371e-012_SRK) &
      .OR. (testET2(5)%maxVal == 0))
ASSERT(bool, 'testET2(5)%initialize(...)')
x1=-10._SRK
y1=1._SRK-EXP(x1)
x2=x1+1.0e-3_SRK
y2=1._SRK-EXP(x2)
DO i=-10000,0
  x3=x2+1.0e-3_SRK
  y3=1._SRK-EXP(x3)
  reftbl(i)=((y1+y3)*0.5_SRK-y2)*1.0e6_SRK
  reftbl2(i)=(-((x2+x3)*y1+(x1+x2)*y3)*0.5_SRK+(x1+x3)*y2)*1.0e6_SRK
  reftbl3(i)=((x3*y1+x1*y3)*x2*0.5_SRK-x1*x3*y2)*1.0e6_SRK
  x1=x2
  x2=x3
  y1=y2
  y2=y3
ENDDO
DO i=-10000,0
  bool = (reftbl(i) .APPROXEQ. testET2(5)%table(i))
  ASSERT(bool, 'testET2(5)%initialize(...)')
  FINFO() i,reftbl(i),testET2(5)%table(i)
ENDDO
DO i=-10000,0
  bool = (reftbl2(i) .APPROXEQ. testET2(5)%table2rd(i))
  ASSERT(bool, 'testET2(5)%initialize(...)')
  FINFO() i,reftbl2(i),testET2(5)%table2rd(i)
ENDDO

DO i=-10000,0
  bool = SOFTEQ(reftbl3(i),testET2(5)%table3rd(i),1.0e-7_SRK)
  ASSERT(bool, 'testET2(5)%initialize(...)')
  FINFO() i,reftbl3(i),testET2(5)%table3rd(i)
ENDDO
WRITE(*,*) '  Passed: CALL testET2(5)%initialize(...) ORDER2'

err(:)=0.0_SRK
CALL PL%set('ExpTables -> nintervals',100)
CALL PL%set('ExpTables -> errorFlag',.TRUE.)
CALL PL%add('ExpTables -> error',9.99e-7_SRK)
DO i=1,5
  CALL testET2(i)%clear()
  CALL PL%set('ExpTables -> tabletype',i)
  CALL testET2(i)%initialize(PL)
  WRITE(*,*) getMemUsageChar()
  ans=testET2(i)%EXPT(x)
  err(i)=ans-(1._SRK-EXP(x))
ENDDO
CALL testET2(5)%clear()
bool = ALL(ABS(err) <= 1e-6_SRK)
ASSERT(bool, 'tableET%EXPT(x)')
WRITE(*,*) '  Passed: tableET%EXPT(x)'

CALL testET1%clear()
bool = (.NOT.testET1%isinit .OR. testET1%tableType == -1 &
      .OR. testET1%nintervals == -1 .OR. (testET1%dx .APPROXEQ. 0._SRK) &
      .OR. (testET1%dx2rd .APPROXEQ. 0._SRK) .OR. (testET1%rdx .APPROXEQ. 0._SRK) &
      .OR. (testET1%rdx2rd .APPROXEQ. 0._SRK) .OR. (testET1%minVal == 0) &
      .OR. (testET1%maxVal == 0) .OR. (testET1%tableErr .APPROXEQ. 0._SRK))
ASSERT(bool, 'testET1%clear()')
FINALIZE_TEST()

CREATE_TEST("subtest POLAR_EXP_TABLE")

REGISTER_SUBTEST("testPOLAR_EXP_TABLE", testPOLAR_EXP_TABLE)

WRITE(*,*) '  Passed: CALL testET1%clear()'
WRITE(*,*) '==================================================='
WRITE(*,*) 'TESTING EXPTABLES COMPLETE!'
WRITE(*,*) '==================================================='
CALL PL%clear()
CALL ErrCheck()
!CALL perftest()
DO i=1,5
  CALL testET2(i)%clear()
ENDDO
CALL ExpTables_Clear_ValidParams()
!CALL bitEXP()

FINALIZE_TEST()

!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> This routine computes the numerical error of the tables which can be used to
!> compare to the analytic expressions for verification.
SUBROUTINE ErrCheck()
  REAL(SRK) :: x(1000),ans(1000),err_result(1000),maxerr,dx
  INTEGER(SIK) :: j,i,ntype,nintervals,itype,maxi
  TYPE(ExpTableType) :: testET

  ntype=5_SIK

  !DO i=2,6
  !  nintervals(i)=nintervals(i-1)*10_SIK
  !ENDDO
  WRITE(*,*)
  WRITE(*,*) '+------------+------------+---------------+'
  WRITE(*,*) '| Table Type | nIntervals | Max Table Err |'
  WRITE(*,*) '+------------+------------+---------------+'
  DO itype=2,5 !ntype
    nintervals=1_SIK
    DO j=2,6
      nintervals=nintervals*10
      CALL PL%set('ExpTables -> tabletype',itype)
      CALL PL%set('ExpTables -> nintervals',nintervals)
      CALL testET%initialize(PL)
      x(1)=0.0_SRK
      IF(itype/=3) THEN
        dx=testET%dx/1000._SRK
      ELSE
        dx=testET%dx2rd/1000._SRK
      ENDIF
      DO i=2,1000
        x(i)=x(i-1)-dx
      ENDDO
      DO i=2,999
        ans(i)=1._SRK-EXP(x(i))
        ans(1)=EXPT(testET,x(i))
        err_result(i)=ABS(ans(i)-ans(1))
      ENDDO
      maxerr=0._SRK
      DO i=2,999
        IF(err_result(i)>maxerr) THEN
          maxerr=err_result(i)
          maxi=i
        ENDIF
      ENDDO
      WRITE(*,'(a,i12,a,i12,a,es15.6,a)') &
      ' |',itype,'|',testET%nintervals,'|',maxerr,'|'
!          WRITE(*,*) itype,testET%nintervals,'Err:',maxi,x(maxi),maxerr
      CALL testET%clear()
    ENDDO
  ENDDO
  WRITE(*,*) '+------------+------------+---------------+'
ENDSUBROUTINE ErrCheck
!
!-------------------------------------------------------------------------------
!This routine was used to generate the performance data with TAU to show
!that the linear interpolation has favorable performance.
SUBROUTINE perftest()
#ifdef TAU
  INTEGER(SIK),SAVE :: profiler1(2)=0
  INTEGER(SIK),SAVE :: profiler2(2)=0
  INTEGER(SIK),SAVE :: profiler3(2)=0
  INTEGER(SIK),SAVE :: profiler4(2)=0
  INTEGER(SIK),SAVE :: profiler5(2)=0
  INTEGER(SIK),SAVE :: profiler6(2)=0
  INTEGER(SIK) :: nval,neval,j,ix
  REAL(SRK),ALLOCATABLE :: xval(:),ans(:)
  TYPE(ExpTableType) :: myTable

  WRITE(*,*)
  WRITE(*,*)
  WRITE(*,*) ' Getting performance measurements...'

  !Set test input for number of evaluations and number of values to evaluate
  neval=100000
  nval=300

  !Setup test input
  ALLOCATE(ans(1:nval))
  ALLOCATE(xval(1:nval))
  CALL RANDOM_NUMBER(xval)
  xval=xval*(-10._SRK)

  CALL TAU_PROFILE_INIT()
  CALL TAU_PROFILE_TIMER(profiler1, 'EXACT EXP()')
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler1)
    DO j=1,nval
      ans(j)=ans(j)+EXP(xval(j))
    ENDDO
    CALL TAU_PROFILE_STOP(profiler1)
  ENDDO

  CALL TAU_PROFILE_TIMER(profiler2, 'EXACT EXP() Array Form')
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler2)
    ans=ans+EXP(xval)
    CALL TAU_PROFILE_STOP(profiler2)
  ENDDO

  CALL TAU_PROFILE_TIMER(profiler3, 'EXACT myTable%EXPT()')
  CALL myTable%initialize(EXACT_EXP_TABLE)
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler3)
    DO j=1,nval
      ans(j)=ans(j)+myTable%EXPT(xval(j))
    ENDDO
    CALL TAU_PROFILE_STOP(profiler3)
  ENDDO
  CALL myTable%clear()

  CALL TAU_PROFILE_TIMER(profiler4, 'LINEAR myTable%EXPT()')
  CALL myTable%initialize(LINEAR_EXP_TABLE)
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler4)
    DO j=1,nval
      ans(j)=ans(j)+myTable%EXPT(xval(j))
    ENDDO
    CALL TAU_PROFILE_STOP(profiler4)
  ENDDO
  CALL myTable%clear()

  CALL TAU_PROFILE_TIMER(profiler5, 'LINEAR EXPLICIT')
  CALL myTable%initialize(LINEAR_EXP_TABLE)
  DO i=1,neval
    ans=REAL(i,SRK)
    CALL TAU_PROFILE_START(profiler5)
    DO j=1,nval
      ix=FLOOR(xval(j)*myTable%rdx)
      ans(j)=ans(j)+myTable%table2D(1,ix)*xval(j)+myTable%table2D(2,ix)
    ENDDO
    CALL TAU_PROFILE_STOP(profiler5)
  ENDDO
  CALL myTable%clear()

  WRITE(*,*) ' Performance measurements completed'
#else
  USE Times
  USE StochasticSampling

  INTEGER(SIK) :: nval,neval,j
  REAL(SRK),ALLOCATABLE :: xval(:),ans(:)
  TYPE(ExpTableType) :: myTable
  TYPE(TimerType) :: testTimer
  TYPE(StochasticSamplingType) :: myRNG

  CALL testTimer%setTimerHiResMode(.TRUE.)
  CALL myRNG%init(RNG_LEcuyer2)
  WRITE(*,*)
  WRITE(*,*)
  WRITE(*,*) ' Getting performance measurements without TAU...'

  !Set test input for number of evaluations and number of values to evaluate
  neval=1000000
  nval=3000

  !Setup test input
  ALLOCATE(ans(1:nval))
  ALLOCATE(xval(1:nval))
  DO j=1,nval
    xval(j)=myRNG%rng()
  ENDDO
  xval=xval*(-10._SRK)

  WRITE(*,*) 'EXACT myTable%EXPT()'
  CALL PL%add('ExpTables -> tabletype',EXACT_EXP_TABLE)
  CALL myTable%initialize(PL)
  CALL testTimer%tic()
  DO i=1,neval
    ans=REAL(i,SRK)
    DO j=1,nval
      ans(j)=ans(j)+myTable%EXPT(xval(j))
    ENDDO
  ENDDO
  CALL testTimer%toc()
  WRITE(*,*) "Took: ", testTimer%elapsedtime
  CALL myTable%clear()

  WRITE(*,*) 'LINEAR myTable%EXPT()'
  CALL PL%set('ExpTables -> tabletype',LINEAR_EXP_TABLE)
  CALL myTable%initialize(PL)
  CALL testTimer%ResetTimer()
  DO i=1,neval
    ans=REAL(i,SRK)
    DO j=1,nval
      ans(j)=ans(j)+myTable%EXPT(xval(j))
    ENDDO
  ENDDO
  CALL testTimer%toc()
  WRITE(*,*) "Took: ", testTimer%elapsedtime
  CALL myTable%clear()
  CALL PL%clear()
  CALL myRNG%clear()

  WRITE(*,*) ' Performance measurements completed'
#endif
ENDSUBROUTINE perftest
!
!-------------------------------------------------------------------------------
!This routine is here to test the performance and feasability of calculating
!the function EXP(x) based on bitwise comparison and operations to see if there
!is any noticable speedup.
SUBROUTINE bitEXP()
  REAL(SSK) :: x,y,xinit
  INTEGER(SNK) :: xint,yint,xinitint
  EQUIVALENCE(x,xint)
  EQUIVALENCE(y,yint)
  EQUIVALENCE(xinit,xinitint)
  INTEGER(SIK) :: i
  !REAL(SSK),ALLOCATABLE :: ans(:),xval(:)
  REAL(SSK) :: logvals(27)

  !Set test input for number of evaluations and number of values to evaluate
  !neval=1
  !nval=1

  !Setup test input
  !ALLOCATE(ans(1:nval))
  !ALLOCATE(xval(1:nval))
  !CALL RANDOM_NUMBER(xval)
  !xval=xval*(-10._SSK)

  !Trial Negative values
  !logvals(1)=LOG(1.0_SSK/256.0_SSK)
  !logvals(2)=LOG(1.0_SSK/16.0_SSK)
  !logvals(3)=LOG(1.0_SSK/4.0_SSK)
  !logvals(4)=LOG(1.0_SSK/2.0_SSK)
  !logvals(5)=LOG(1.0_SSK/1.5_SSK)
  !logvals(6)=LOG(1.0_SSK/1.25_SSK)
  !logvals(7)=LOG(1.0_SSK/1.125_SSK)
  !logvals(8)=LOG(1.0_SSK/1.0625_SSK)
  !logvals(9)=LOG(1.0_SSK/1.03125_SSK)
  !logvals(10)=LOG(1.0_SSK/1.015625_SSK)
  !logvals(11)=LOG(1.0_SSK/1.007813_SSK)
  !logvals(12)=LOG(1.0_SSK/1.003906_SSK)
  !logvals(13)=LOG(1.0_SSK/1.001953_SSK)
  !logvals(14)=LOG(1.0_SSK/1.000977_SSK)
  !logvals(15)=LOG(1.0_SSK/1.000488_SSK)
  !logvals(16)=LOG(1.0_SSK/1.000244_SSK)
  !logvals(17)=LOG(1.0_SSK/1.000122_SSK)
  !logvals(18)=LOG(1.0_SSK/1.000061_SSK)
  !logvals(19)=LOG(1.0_SSK/1.000031_SSK)
  !logvals(20)=LOG(1.0_SSK/1.000015_SSK)
  !logvals(21)=LOG(1.0_SSK/1.000008_SSK)
  !logvals(22)=LOG(1.0_SSK/1.000004_SSK)
  !logvals(23)=LOG(1.0_SSK/1.000002_SSK)
  !Positive Values
  logvals(1)=LOG(256.00000_SSK)
  logvals(2)=LOG(16.000000_SSK)
  logvals(3)=LOG(4.0000000_SSK)
  logvals(4)=LOG(2.0000000_SSK)
  logvals(5)=LOG(1.5000000_SSK)
  logvals(6)=LOG(1.2500000_SSK)
  logvals(7)=LOG(1.1250000_SSK)
  logvals(8)=LOG(1.0625000_SSK)
  logvals(9)=LOG(1.0312500_SSK)
  logvals(10)=LOG(1.0156250_SSK)
  logvals(11)=LOG(1.0078125_SSK)
  logvals(12)=LOG(1.0039063_SSK)
  logvals(13)=LOG(1.0019531_SSK)
  logvals(14)=LOG(1.0009766_SSK)
  logvals(15)=LOG(1.0004883_SSK)
  logvals(16)=LOG(1.0002441_SSK)
  logvals(17)=LOG(1.0001221_SSK)
  logvals(18)=LOG(1.0000610_SSK)
  logvals(19)=LOG(1.0000305_SSK)
  logvals(20)=LOG(1.0000153_SSK)
  logvals(21)=LOG(1.0000076_SSK)
  logvals(22)=LOG(1.0000038_SSK)
  logvals(23)=LOG(1.0000019_SSK)
  logvals(24)=LOG(1.0000010_SSK)
  logvals(25)=LOG(1.0000005_SSK)
  logvals(26)=LOG(1.0000002_SSK)
  logvals(27)=LOG(1.0000001_SSK)

  x=-10._SSK
  xinit=EXP(x)
  y=4.54E-5_SSK
  WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',xinit
  WRITE(*,*) 'Printing X...'
  CALL printBit(xint)
  WRITE(*,*) 'Printing Y...'
  CALL printBit(yint)

  !Get it to work for positive numbers first.

  x=0.5_SSK
  xinit=EXP(x)
  y=1.0_SRK
  !yint=1073741824_SIK
  !yint=65536_SIK
  WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',xinit
  WRITE(*,*) 'Printing EXP(Xinitial)...'
  CALL printBit(xinitint)
  WRITE(*,*) 'Printing Y...'
  CALL printBit(yint)
  DO i=1,5
    IF(x >= logvals(i)) THEN
      x=x-logvals(i); yint=IBSET(yint,27-i)
    ENDIF
    WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',xinit
    WRITE(*,*) 'Printing EXP(Xinitial)...'
    CALL printBit(xinitint)
    WRITE(*,*) 'Printing Y...'
    CALL printBit(yint)
  ENDDO
  DO i=6,24
    IF(x >= logvals(i)) THEN
      x=x-logvals(i); yint=IBSET(yint,27-i)
    ENDIF
    WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',xinit
    WRITE(*,*) 'Printing EXP(Xinitial)...'
    CALL printBit(xinitint)
    WRITE(*,*) 'Printing Y...'
    CALL printBit(yint)
  ENDDO
  !DO i=1,10
  !  !Add 1._SSK to x
  !  x=x-1.0_SSK
  !  WRITE(*,*) 'x=',x,'y=',y,'EXP(x)=',EXP(x)
  !  CALL printBit(xint)
  !ENDDO

  !DO i=1,neval
  !
  !ENDDO

ENDSUBROUTINE bitEXP
!
!-------------------------------------------------------------------------------
!Functionalizing the Bit Printing I'll probably need mulitple times.
!Prints the bit number from 31-0 for 32-bit values, prints the s,x,m
!notation for IEEE-754 single precision reals, and then prints the bits in the
!corresponding order.  (Haven't expanded this to take into account endian-ness)
!
!The integer specified by the input should be "equivalenced" (shares the same
!memory location with) a single precision real number.  Bit-wise operations are
!only available through integers.
!
SUBROUTINE printBit(int)
  INTEGER(SNK),INTENT(INOUT) :: int
  INTEGER(SIK) :: i,bprint(32)
  LOGICAL(SBK) :: flag(32)

  bprint=0_SIK
  DO i=1,32
    !Apparently, there is a zero bit, who knew.
    flag(i)=BTEST(int,i-1)
    IF(flag(i)) bprint(i)=1_SIK
  ENDDO
  WRITE(*,*) '      10987654321098765432109876543210'
  WRITE(*,*) '      sxxxxxxxxmmmmmmmmmmmmmmmmmmmmmmm'
  WRITE(*,'(a,32i1)') '       ',(bprint(i),i=32,1,-1)
  WRITE(*,*) '--------------------------------------'
ENDSUBROUTINE printBit
!
!-------------------------------------------------------------------------------
!This routine is here to test the performance and feasability of calculating
!the function EXP(x) based on bitwise comparison and operations to see if there
!is any noticable speedup.
SUBROUTINE testPOLAR_EXP_TABLE()
  TYPE(ExpTableType) :: testET
  TYPE(ParamType),SAVE :: PL
  REAL(SRK),ALLOCATABLE :: rsinpol(:)
  INTEGER(SIK) :: ipol,i
  REAL(SRK) :: y,result,x

  CALL PL%clear()
  !Set names for required parameters
  !Set defaults for optional parameters
  CALL PL%add('ExpTables -> tabletype',POLAR_EXP_TABLE)
  CALL PL%add('ExpTables -> minval',-10._SRK)
  CALL PL%add('ExpTables -> maxval',0._SRK)
  CALL PL%add('ExpTables -> nintervals',1000)
  CALL PL%add('ExpTables -> error',0.0005_SRK)
  CALL PL%add('ExpTables -> errorflag',.FALSE.)
  ALLOCATE(rsinpol(3))
  rsinpol=(/6.000672075_SRK,1.859748897_SRK,1.071864208_SRK/)
  CALL PL%add('ExpTables -> RSIN_polars',rsinpol)

  !Initialize the exponential table
  CALL testET%initialize(PL)
  !Error Checking
  ASSERT(testET%nintervals==1000,"nintervals")
  ASSERT(testET%tableType==POLAR_EXP_TABLE,"tableType")
  ASSERT(testET%maxVal==0._SRK,"maxVal")
  ASSERT(testET%minVal==-10._SRK,"minVal")
  ASSERT(testET%minTable==-10000,"minTable")
  FINFO() "minTable",testET%minTable
  FINFO() "minTable_ref",-1000
  ASSERT(testET%rdx==1000,"rdx")
  ASSERT(testET%dx==0.001_SRK,"dx")
  ASSERT(SOFTEQ(testET%tableErr,1.249999999E-007_SRK,1e-6_SRK),"tableErr")
  FINFO() "tableErr",testET%tableErr
  FINFO() "tableErr_ref",1.249999999E-007_SRk

  DO ipol=1,3
    x=-10.001_SRK
    DO i=-10000,0
      x=x+0.001_SRK
      y=1._SRK-EXP(x*rsinpol(ipol))
      result=testET%EXPT(x,ipol)
      !Comparing the table lookup result with the system function evaluation
      !instead of checking the coeff in the table themselves
      ASSERT(SOFTEQ(result,y,1.249999999E-007_SRK),"resultOfFunctionCall")
      FINFO() "tableLookUp",result,i,ipol
      FINFO() "reference",y
    ENDDO
  ENDDO

  DEALLOCATE(rsinpol)
  CALL testET%clear()
  CALL PL%clear()
ENDSUBROUTINE testPOLAR_EXP_TABLE
!
ENDPROGRAM testExpTables


      INTEGER FUNCTION FINDELEMENT(K,A,N)	!I know I can.
Chase an order statistic: FindElement(N/2,A,N) leads to the median, with some odd/even caution.
Careful! The array is shuffled: for i < K, A(i) <= A(K); for i > K, A(i) >= A(K).
Charles Anthony Richard Hoare devised this method, as related to his famous QuickSort.
       INTEGER K,N		!Find the K'th element in order of an array of N elements, not necessarily in order.
       INTEGER A(N),HOPE,PESTY	!The array, and like associates.
       INTEGER L,R,L2,R2	!Fingers.
        L = 1			!Here we go.
        R = N			!The bounds of the work area within which the K'th element lurks.
        DO WHILE (L .LT. R)	!So, keep going until it is clamped.
          HOPE = A(K)		!If array A is sorted, this will be rewarded.
          L2 = L		!But it probably isn't sorted.
          R2 = R		!So prepare a scan.
          DO WHILE (L2 .LE. R2)	!Keep squeezing until the inner teeth meet.
            DO WHILE (A(L2) .LT. HOPE)	!Pass elements less than HOPE.
              L2 = L2 + 1		!Note that at least element A(K) equals HOPE.
            END DO			!Raising the lower jaw.
            DO WHILE (HOPE .LT. A(R2))	!Elements higher than HOPE
              R2 = R2 - 1		!Are in the desired place.
            END DO			!And so we speed past them.
            IF (L2 - R2) 1,2,3	!How have the teeth paused?
    1       PESTY = A(L2)		!On grit. A(L2) > HOPE and A(R2) < HOPE.
            A(L2) = A(R2)		!So swap the two troublemakers.
            A(R2) = PESTY		!To be as if they had been in the desired order all along.
    2       L2 = L2 + 1		!Advance my teeth.
            R2 = R2 - 1		!As if they hadn't paused on this pest.
    3     END DO		!And resume the squeeze, hopefully closing in K.
          IF (R2 .LT. K) L = L2	!The end point gives the order position of value HOPE.
          IF (K .LT. L2) R = R2	!But we want the value of order position K.
        END DO			!Have my teeth met yet?
        FINDELEMENT = A(K)	!Yes. A(K) now has the K'th element in order.
      END FUNCTION FINDELEMENT	!Remember! Array A has likely had some elements moved!

      PROGRAM POKE
      INTEGER FINDELEMENT	!Not the default type for F.
      INTEGER N			!The number of elements.
      PARAMETER (N = 10)	!Fixed for the test problem.
      INTEGER A(66)		!An array of integers.
      DATA A(1:N)/9, 8, 7, 6, 5, 0, 1, 2, 3, 4/	!The specified values.

      WRITE (6,1) A(1:N)	!Announce, and add a heading.
    1 FORMAT ("Selection of the i'th element in order from an array.",/
     1 "The array need not be in order, and may be reordered.",/
     2 "  i Val:Array elements...",/,8X,666I2)

      DO I = 1,N	!One by one,
        WRITE (6,2) I,FINDELEMENT(I,A,N),A(1:N)	!Request the i'th element.
    2   FORMAT (I3,I4,":",666I2)	!Match FORMAT 1.
      END DO		!On to the next trial.

      END	!That was easy.


program test1
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
 use modsparse
 implicit none
 integer(kind=int32)::nrow
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 real(kind=wp)::val
 logical::lup=.false.
 type(coosparse)::coo
 type(crssparse)::crs,crs1

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(8,5)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(8,5)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row+2,col+2,val)
 end do
 close(iunit)

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(8)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
  call coo%add(col,row,val)
 end do
 close(iunit)

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(8)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row+2,col+2,val)
  call coo%add(col+2,row+2,val)
 end do
 close(iunit)

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(5,8)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(5,8)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row+2,col+2,val)
  call coo%add(col+2,row+2,val)
 end do
 close(iunit)

 call coo%printstats()
 call coo%print()
 call coo%printsquare()
 !call coo%print(lint=.false.)

 crs=coo
 call crs%printstats()
 call crs%print()
 call crs%printsquare()

end program


! Program to test WHERE inside FORALL
program where_1
   integer :: A(5,5)

   A(1,:) = (/1,0,0,0,0/)
   A(2,:) = (/2,1,1,1,0/)
   A(3,:) = (/1,2,2,0,2/)
   A(4,:) = (/2,1,0,2,3/)
   A(5,:) = (/1,0,0,0,0/)

   ! Where inside FORALL.
   ! WHERE masks must be evaluated before executing the assignments
   forall (I=1:5)
      where (A(I,:) .EQ. 0)
         A(:,I) = I
      elsewhere (A(I,:) >2)
         A(I,:) = 6
      endwhere
   end forall

   if (any (A .ne. reshape ((/1, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 1, 2, 3, 0, &
      0, 1, 4, 2, 0, 0, 5, 6, 6, 5/), (/5, 5/)))) call abort

   ! Where inside DO
   A(1,:) = (/1,0,0,0,0/)
   A(2,:) = (/2,1,1,1,0/)
   A(3,:) = (/1,2,2,0,2/)
   A(4,:) = (/2,1,0,2,3/)
   A(5,:) = (/1,0,0,0,0/)

   do I=1,5
      where (A(I,:) .EQ. 0)
         A(:,I) = I
      elsewhere (A(I,:) >2)
         A(I,:) = 6
      endwhere
   enddo

   if (any (A .ne. reshape ((/1, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 1, 2, 6, 0, &
      0, 1, 0, 2, 0, 0, 0, 5, 5, 5/), (/5, 5/)))) call abort
end


Subroutine Velcorrect
use Aero2DCOM
implicit none
integer i,j
if(solctrl=='SIMPLE') then
   DO j=1,Jc-1
     DO i=2,Ic-1
       U(i,j)=U(i,j)-Rau*dPx(i,j)*Jg(i,j)*dx*dy/auP(i,j)
       V(i,j)=V(i,j)-Rau*dPy(i,j)*Jg(i,j)*dx*dy/auP(i,j)
     end DO
   end DO
else if(solctrl=='SIMPLEC') then
   DO j=1,Jc-1
     DO i=2,Ic-1
       U(i,j)=U(i,j)-Rau*dPx(i,j)*Jg(i,j)*dx*dy/(auP(i,j)-Rau*auNB(i,j))
       V(i,j)=V(i,j)-Rau*dPy(i,j)*Jg(i,j)*dx*dy/(auP(i,j)-Rau*auNB(i,j))
     end DO
   end DO
end if
DO j=1,Jc-1
  DO i=2,Ic
   Unk(i,j)=Unk(i,j)+duk(i,j)*(dP(i-1,j)-dP(i,j))
  end DO
end DO
DO j=1,Jc
  DO i=2,Ic-1
   if(j==1.and.(i>Ib2.or.i<Ib1)) then
    Vna(i,j)=Vna(i,j)+dva(i,j)*(dP(Ic+1-i,j)-dP(i,j))
   else if(j==1) then
    Vna(i,j)=Vna(i,j)
   else
    Vna(i,j)=Vna(i,j)+dva(i,j)*(dP(i,j-1)-dP(i,j))
   end if
  end DO
end DO
Un=U*Yga-V*Xga
Vn=V*Xgk-U*Ygk
end Subroutine Velcorrect


      program DRDPOI
c>> 2001-05-25 DRDPOI Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRDPOI Krogh  Changed Fortran 90 code.
c>> 1994-10-19 DRDPOI Krogh  Changes to use M77CON
c>> 1994-07-06 DRDPOI WVS set up for chgtyp
c
c     Evaluate the Probability Function Q(n,lamda) of the Poisson
c     distribution by using DCDPOI.
c
c--D replaces "?": DR?POI, ?cdpoi, ?gamik
      double precision LAMDAS(4), P, Q(4)
      integer N, IERR, J
      data LAMDAS /0.5d0, 1.0d0, 1.5d0, 2.0d0/
c
10    format ('     Poisson Probability Function Q(lamda | n)'/
     1        '  N    LAMDA =',4f14.7/)
30    format (i3,15x,1p,4g14.7)
      call dgamik (0.0d0, 0.0d0, 0.0d0, 0)
      print 10, lamdas
      do 50 n = 1, 10
         do 40 j = 1, 4
            call dcdpoi (n, lamdas(j), p, q(j), ierr)
40       continue
         print 30, n, q
50    continue
      stop
      end


      REAL FUNCTION gennf(dfn,dfd,xnonc)

C**********************************************************************
C
C     REAL FUNCTION GENNF( DFN, DFD, XNONC )
C           GENerate random deviate from the Noncentral F distribution
C
C
C                              Function
C
C
C     Generates a random deviate from the  noncentral F (variance ratio)
C     distribution with DFN degrees of freedom in the numerator, and DFD
C     degrees of freedom in the denominator, and noncentrality parameter
C     XNONC.
C
C
C                              Arguments
C
C
C     DFN --> Numerator degrees of freedom
C             (Must be >= 1.0)
C                              REAL DFN
C      DFD --> Denominator degrees of freedom
C             (Must be positive)
C                              REAL DFD
C
C     XNONC --> Noncentrality parameter
C               (Must be nonnegative)
C                              REAL XNONC
C
C
C                              Method
C
C
C     Directly generates ratio of noncentral numerator chisquare variate
C     to central denominator chisquare variate.
C
C**********************************************************************
C     .. Scalar Arguments ..
      REAL dfd,dfn,xnonc
C     ..
C     .. Local Scalars ..
      REAL xden,xnum
      LOGICAL qcond
C     ..
C     .. External Functions ..
      REAL genchi,gennch
      EXTERNAL genchi,gennch
C     ..
C     .. Executable Statements ..
      qcond = dfn .LE. 1.0 .OR. dfd .LE. 0.0 .OR. xnonc .LT. 0.0
      IF (.NOT. (qcond)) GO TO 10
      WRITE (*,*) 'In GENNF - Either (1) Numerator DF <= 1.0 or'
      WRITE (*,*) '(2) Denominator DF < 0.0 or '
      WRITE (*,*) '(3) Noncentrality parameter < 0.0'
      WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd,'XNONC value: ',
     +  xnonc
      STOP 'Degrees of freedom or noncent param our of range in GENNF'

   10 xnum = gennch(dfn,xnonc)/dfn
C      GENNF = ( GENNCH( DFN, XNONC ) / DFN ) / ( GENCHI( DFD ) / DFD )
      xden = genchi(dfd)/dfd
      IF (.NOT. (xden.LE. (1.0E-38*xnum))) GO TO 20
      WRITE (*,*) ' GENNF - generated numbers would cause overflow'
      WRITE (*,*) ' Numerator ',xnum,' Denominator ',xden
      WRITE (*,*) ' GENNF returning 1.0E38'
      gennf = 1.0E38
      GO TO 30

   20 gennf = xnum/xden
   30 RETURN

      END


module derivatives_y_mod

USE Variablen
USE sync_mod
USE wang_johnson_mod

CONTAINS

! 1.Ableitung nach y mit periodischen RB
SUBROUTINE Dphi_Dy_p(phi,sphi,qi_i,qi_nr,qi_r) !Dphi_Dy_p(rho_u,solve,qxi_i,qxi_nr,qxi_r)

	IMPLICIT NONE

	INTEGER::h,i,j
	REAL::phi(-1:m_local+2,-1:n_local+2,-1:o_local+2),sphi(1:m_local,1:n_local,1:o_local)
	REAL::qi_i,qi_r,qi_nr
	INTEGER::image(3)
	CALL SYNC_NEIGHBOURS_P

Do j=1,m_local
	DO i=1,o_local
		sphi(j,1,i)=0.5*(phi(j,2,i)-phi(j,n_local,i))/dy
		DO h=2,n_local-1
			sphi(j,h,i)=0.5*(phi(j,h+1,i)-phi(j,h-1,i))/dy
		ENDDO
		sphi(j,n_local,i)=0.5*(phi(j,1,i)-phi(j,n_local-1,i))/dy
	ENDDO
ENDDO

	CALL SYNC_NEIGHBOURS_P

	RETURN

END SUBROUTINE

end module


      SUBROUTINE gety2(y, y2, h, nots, nb)
      USE vspline
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER nots, nb
      REAL(rprec), DIMENSION(*) :: y, y2, h
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER jmax
      REAL(rprec), DIMENSION(nots) :: aspline, bspline, dspline
C-----------------------------------------------

      jspmin(1) = 2
      IF (nb .eq. ideriv) jspmin(1) = 1
      jmax = nots - 1
      aspline(1) = h(1)
      dspline(1) = 2.0*h(1)
      y2(1) = 0.
      y2(nots) = 0.
      IF (nb .eq. ideriv) y2(1) = 6.0*(y(2)-y(1))/h(1)
      aspline(2:jmax) = h(2:jmax)
      bspline(2:jmax) = h(:jmax-1)
      dspline(2:jmax) = 2.0*(h(2:jmax)+h(:jmax-1))
      y2(2:jmax) = 6.0*((y(3:jmax+1)-y(2:jmax))/h(2:jmax)
     1   -(y(2:jmax)-y(:jmax-1))/h(:jmax-1))

      CALL tridslv(aspline,dspline,bspline,y2,jspmin,jmax,0,nots,1)

      END SUBROUTINE gety2


      subroutine ferfc(y, x, n)
      integer n, i
      double precision y(n), x(n), xx, t, z, p
      do i= 1, n
         xx= x(i)
         z= abs(xx)
         t= 1.0/(1.0+0.5*z)
         p= -1.26551223 +
     &      t*(1.00002368 + t*(0.37409196 + t*(0.09678418 +
     &      t*(-0.18628806 + t*(0.27886807 + t*(-1.13520398 +
     &      t*(1.48851587 + t*(-0.82215223 + t*0.17087277))))))))
         p= t*exp(-z*z + p)
         if (xx .lt. 0.) then
            p= 2.-p
         endif
         y(i)= p
      enddo
      return
      end


c
c  This file contains the Laplace FMM wrappers
c
c  The laplace FMM evaluates the following potential
c  and its gradient
c
c     u_{l}(x) = \sum_{j=1}^{N} c_{l,j}/|x-x_{j}| -
c         v_{l,j}.\nabla (1/|x-x_{j}|)
c
c  Here x_{j} are the source locations, c_{l,j} are the charge strengths,
c  v_{l,j} are the dipole strengths. We refer to the collection of
c  $x$ at which the potential and its gradient are evaluated as the
c  evaluation points
c
c  This file contains the wrappers to the vectorized routines
c
c  The subroutine names take the following form:
c    lfmm3d_<eval-pts>_<int-ker>_<out>_vec
c
c      <eval-pts>: evaluation points (sources/targets/sources+targets)
c        s: source locations
c        t: target locations
c        st: source and target locations
c
c      <int-ker>: kernel of interaction (charges/dipoles/both)
c        c: charges
c        d: dipoles
c        cd: charges+dipoles
c
c      <out>: flag for potential/potential+gradient
c        p: potentials
c        g: potentials+gradients
c
c  The wrappers are:
c
c  -lfmm3d_s_c_p_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_s_c_g_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_s_d_p_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_s_d_g_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_s_cd_p_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_s_cd_g_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_t_c_p_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_t_c_g_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_t_d_p_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_t_d_g_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_t_cd_p_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_t_cd_g_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_st_c_p_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_st_c_g_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_st_d_p_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_st_d_g_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_st_cd_p_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_st_cd_g_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c
c

      subroutine lfmm3d_s_c_p_vec(nd,eps,nsource,source,
     1    charge,pot)
      implicit none
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(out) pot
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|}
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c
c
c--------------------------------
c

      double precision eps
      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,1)
      double precision charge(nd,nsource)

      double precision dipvec(nd,3,1)

      double precision pot(nd,nsource)

      double precision pottarg(nd,1)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_s_c_g_vec(nd,eps,nsource,source,
     1    charge,pot,grad)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(out) pot,grad
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|}
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double precision(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,1)
      double precision charge(nd,nsource)

      double precision dipvec(nd,3,1)

      double precision pot(nd,nsource),grad(nd,3,nsource)
      double precision pottarg(nd,1),gradtarg(nd,3,1)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_s_d_p_vec(nd,eps,nsource,source,
     1    dipvec,pot)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(out) pot
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,1)
      double precision charge(nd,1)

      double precision dipvec(nd,3,nsource)

      double precision pot(nd,nsource)
      double precision pottarg(nd,1)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_s_d_g_vec(nd,eps,nsource,source,
     1    dipvec,pot,grad)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(out) pot,grad
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double precision(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,1)
      double precision charge(nd,1)

      double precision dipvec(nd,3,nsource)

      double precision pot(nd,nsource),grad(nd,3,nsource)
      double precision pottarg(nd,1),gradtarg(nd,3,1)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_s_cd_p_vec(nd,eps,nsource,source,
     1    charge,dipvec,pot)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(out) pot
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,1)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,nsource)

      double precision pot(nd,nsource)
      double precision pottarg(nd,1)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c
c
c
c
c
c

      subroutine lfmm3d_s_cd_g_vec(nd,eps,nsource,source,
     1    charge,dipvec,pot,grad)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(out) pot,grad
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double precision(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,1)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,nsource)

      double precision pot(nd,nsource),grad(nd,3,nsource)
      double precision pottarg(nd,1),gradtarg(nd,3,1)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_t_c_p_vec(nd,eps,nsource,source,
     1    charge,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|}
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,1)

      double precision pot(nd,1)
      double precision pottarg(nd,ntarg)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 1

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_t_c_g_vec(nd,eps,nsource,source,
     1    charge,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|}
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double precision(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,1)

      double precision pot(nd,1),grad(nd,3,1)
      double precision pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 2

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_t_d_p_vec(nd,eps,nsource,source,
     1    dipvec,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,1)

      double precision dipvec(nd,3,nsource)

      double precision pot(nd,1)
      double precision pottarg(nd,ntarg)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 1

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_t_d_g_vec(nd,eps,nsource,source,
     1    dipvec,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double precision(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,1)

      double precision dipvec(nd,3,nsource)

      double precision pot(nd,1),grad(nd,3,1)
      double precision pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 2

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_t_cd_p_vec(nd,eps,nsource,source,
     1    charge,dipvec,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,nsource)

      double precision pot(nd,1)
      double precision pottarg(nd,ntarg)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 1

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_t_cd_g_vec(nd,eps,nsource,source,
     1    charge,dipvec,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double precision(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,nsource)

      double precision pot(nd,1),grad(nd,3,1)
      double precision pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 2

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_st_c_p_vec(nd,eps,nsource,source,
     1    charge,pot,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|}
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
cc    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,1)

      double precision pot(nd,nsource)
      double precision pottarg(nd,ntarg)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 1

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_st_c_g_vec(nd,eps,nsource,source,
     1    charge,pot,grad,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|}
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double precision(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
cc    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double precision(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,1)

      double precision pot(nd,nsource),grad(nd,3,nsource)
      double precision pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 2

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_st_d_p_vec(nd,eps,nsource,source,
     1    dipvec,pot,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
cc    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,1)

      double precision dipvec(nd,3,nsource)

      double precision pot(nd,nsource)
      double precision pottarg(nd,ntarg)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_st_d_g_vec(nd,eps,nsource,source,
     1    dipvec,pot,grad,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double precision(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
cc    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double precision(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,1)

      double precision dipvec(nd,3,nsource)

      double precision pot(nd,nsource),grad(nd,3,nsource)
      double precision pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_st_cd_p_vec(nd,eps,nsource,source,
     1    charge,dipvec,pot,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
cc    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,nsource)

      double precision pot(nd,nsource)
      double precision pottarg(nd,ntarg)

      double precision grad(nd,3),gradtarg(nd,3)
      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_st_cd_g_vec(nd,eps,nsource,source,
     1    charge,dipvec,pot,grad,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j} \frac{1}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double precision(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double precision(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
cc    -    pottarg: double precision(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double precision(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nd,nsource)
      double precision dipvec(nd,3,nsource)

      double precision pot(nd,nsource),grad(nd,3,nsource)
      double precision pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double precision hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg)

      return
      end
c
c
c
c
c


subroutine primaryPSF(distortion,xdim,ydim,z,length,x0,N,wave,primfoc,r0,graze,psf)
  !Declarations
  implicit none
  integer, intent(in) :: xdim,ydim,N
  real*8, intent(in), dimension(xdim,ydim) :: distortion
  real*8, intent(in), dimension(ydim) :: z
  real*8, intent(in), dimension(N) :: x0
  real*8, intent(in), dimension(xdim) :: length
  real*8, intent(in) :: wave,primfoc,r0,graze
  complex*16 :: j,integrand
  real*8, intent(out), dimension(N) :: psf
  integer :: i,xi,yi
  real*8 :: d2,lengthsum,dz,dummy,pi

  !Constants
  j = (0.,1.)
  lengthsum = sum(length)
  dz = abs(z(2)-z(1))
  pi = acos(-1.)

  do i = 1,N
    psf(i) = 0.
    do xi = 1,xdim
      !Compute integral over axial dimension
      integrand = 0.
      !$omp parallel do reduction(+:integrand) private(d2)
      do yi = 1,ydim
        if (isnan(distortion(xi,yi)) .eqv. .False.) then
          d2 = sqrt((distortion(xi,yi)-x0(i))**2 + (z(yi)+primfoc)**2)
          integrand = integrand + exp(-2*j*pi*(d2-z(yi))/wave)*sqrt(distortion(xi,yi)/d2)
          !print *, distortion(xi,yi), z(yi), d2, integrand
          !read *, dummy
        end if
      end do
      !$omp end parallel do
      !Add weighted integral to relevant observation point
      !print *, integrand,abs(integrand)**2,x0(i)
      psf(i) = psf(i) + abs(integrand)**2*sin(graze)*dz**2/wave/r0/lengthsum
      !print *, psf(i)
      !read *, dummy
    end do

  end do

end subroutine primaryPSF


C
       real*4 function ct_enh_grey( rgb, ci, cimin, cimax )
C      ----------------------------------------------------
C
C Function defining an enhanced grey-scale.
C
C defining:
C             x = (ci-cimin)/(cimax-cimin)
C then:
C   ct_enh_grey = ((x-lower_bound)/(upper_bound-lower_bound))**power_law
C
C for:
C  lower_bound  <=  x  <=  upper_bound
C
C otherwise:
C   ct_enh_grey = 0.0
C
C Where the parameters upper_bound, lower_bound and power_law are passed
C in common.
*-

       include '../include/tv_modify.inc'

       integer        rgb, ci, cimin, cimax
       real*4         x
       x  = (float(ci-cimin)/float(cimax-cimin))
       if (x.ge.lower_bound .and. x.le.upper_bound) then
         ct_enh_grey = ((x-lower_bound)/(upper_bound-lower_bound))**
     *                 power_law
       else if (x.lt.lower_bound) then
         ct_enh_grey = 0.0
       else
         ct_enh_grey = 1.0
       end if
       end


!     JKR, 09.07.95
      SUBROUTINE resample(mode,rdst,wo,fo,so,no,go,w,f,g,s,n,k,xdst)
!
      INCLUDE 'physcnst.inc'
      INTEGER*4 no,n,k  ! input number, output number, actual number
      INTEGER*4 ntmp
      INTEGER*4 mode    ! 0: exact rdst , 1: rdst is min. dw,
!                         2: next power of 2
      REAL*4    fo(no),so(no),go(no),f(n),s(n),g(n)   ! flux, sigma
      REAL*8    rdst    ! resmpling distance
      REAL*8    wo(no),w(n) ! wavelength
      REAL*8    xdst    ! new resampling distance
      REAL*8    dwmin   ! temporary min. resampling distance

!     determination of xdst and establish new w scale

      xdst = 0.D0
      k    = INT( (wo(n)-wo(1)) / rdst + 0.5 )
      xdst = rdst
      IF     (mode.GE.1) THEN
        dwmin = 1.D36
        DO i=2,no
           IF ( (wo(i) - wo(i-1)) .LT. dwmin ) dwmin = wo(i)-wo(i-1)
        END DO
        IF (mode.EQ.2) THEN
         xdst = DMAX1(dwmin*0.9D0,rdst)
         k = 2**( 1 + INT(log10((wo(n)-wo(1))/xdst) / LOG2 ))
         xdst =  ( wo(n)-wo(1) ) / (DBLE(k - 1))
        ELSE
          xdst = DMAX1(dwmin*0.7D0,rdst)
          k    = INT( (wo(n)-wo(1)) / xdst + 0.5 )
        ENDIF
      ENDIF

!     Interpolation

      w(1) = wo(1)
      f(1) = fo(1)
      s(1) = so(1)
      g(1) = go(1)
      ntmp = 1
      DO i = 2,k
         w(i) = w(i-1) + xdst
         f(i) = QPOL1(w(i),wo,fo,no,ntmp)
         s(i) = QPOL1(w(i),wo,so,no,ntmp)
         g(i) = QPOL1(w(i),wo,go,no,ntmp)
      ENDDO

      RETURN
      END


subroutine b4step2(mbc,mx,my,meqn,q,xlower,ylower,dx,dy,t,dt,maux,aux)

    use geoclaw_module
    use topo_module
    use dz_module

    implicit none

    ! Input
    integer(kind=4), intent(in) :: mbc, mx, my, meqn, maux
    real(kind=8), intent(in) :: xlower, ylower, dx, dy, t, dt

    real(kind=8), intent(in out) :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    real(kind=8), intent(in out) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Locals
    integer(kind=4) :: i, j, i1, i2
    character(len=25) :: bfname
    real(kind=8) :: bt, bx, runup1, runup2, x, axi, bxi, eta, x2, xc, xi, z
    real(kind=8) :: zeta

    ! parameters
    real(kind=8), parameter :: tol = 1d-6

    ! Common block
    real(kind=8) :: ybar1, ybar2
    common /comrunup/ ybar1, ybar2

    if (dx <= dxfine) then
        ! Only do this on finest grid
        do i = 1, mx
            if (q(1, i, 1) < 0.001d0) then
                i1 = 1
            end if
            if (q(1, i, 1) < 0.0005d0) then
                i2 = i
            end if
        end do
        runup1 = tanth * (xlower + i1 * dx)
        runup2 = tanth * (xlower + i2 * dx)
        write(32, "(3e20.10)") t, runup1, runup2
    end if

    do j = 1 - mbc, my + mbc
        eta = ylower + (j - 0.5d0) * dy
        do i = 1 - mbc, mx + mbc
            x = xlower + (i - 0.5d0) * dx

            ! Slope with no mass
            z = -x * tanth
            if ((abs(x - xc) < xlength) .and. (eta < width)) then
                ! Region of landslide mass
                x4zeroin = x
                eta4zeroin = eta
                axi = xic - length
                bxi = xic + length
                ! TODO: not sure where this function is coming from
                xi = zeroin(axi, bxi, fxi, tol)
                zeta = zeta_fcn(xi - xic, eta)
                x2 = xi * costh + zeta * sinth
                z = -xi * sinth + zeta * costh
                if (abs(x - x2) > tol) then
                    stop "ERROR"
                end if
            end if
            aux(1, i, j) = max(z, -1.5d0)
        end do
    end do

    ! Check for NaNs
    call check4nans(meqn, mbc, mx, my, q, t, 1)

    forall(i=1-mbc:mx+mbc, j=1-mbc:my+mbc,q(1,i,j) < dry_tolerance)
        q(1,i,j) = max(q(1,i,j),0.d0)
        q(2:3,i,j) = 0.d0
    end forall

end subroutine b4step2


SUBROUTINE mgo_coord
!======================================
! MgO Fermi CNi
!======================================
! Calculating the fermi coordination number for MgO
! Use the mgo_coor_fb subroutine to make use of the polynomial CNi
!======================================

 !USE OMP_LIB                                                 !>>> CPU_TIME
 USE PARACLUSTER
 USE CLUSTER
 USE POTENTIAL
 USE ENFORCE
 USE DISTANCE
 USE SUBSTRATE

 IMPLICIT NONE

 integer               :: i, j, k
 REAL(8)      		   :: comfactor, gamma_sub, gamma_sub_1, gamma_sub_2
 REAL(8), ALLOCATABLE  :: dij(:,:), df_dx(:,:), df_dy(:,:), df_dz(:,:)
 !REAL(8) :: t_start, t_end                                   !>>> CPU_TIME
 !t_start = OMP_GET_WTIME()                                   !>>> CPU_TIME

IF (ipas.EQ.1) WRITE(*,*) 'mgo_coord:> first calculation of CN for MgO substrate'
IF (ipas==1) WRITE(*,*) 'mgo_coord:> aretebim [A]',aretebim
ALLOCATE(dij(natom,natom), df_dx(natom,natom),df_dy(natom,natom),df_dz(natom,natom))
!
df_dx(:,:) = 0.d0
df_dy(:,:) = 0.d0
df_dz(:,:) = 0.d0
!
!coordination number using a smooth Fermi function as
!CN(i) = sum_{j\=i} 1 / [1+exp^alpha(rij/rc-1)]
!beta_sub = alpha_sub/ (rc_sub/aretebim)
!cn(i) = sum_{j/=i} 1 / 1+gamma_sub
!
!$OMP PARALLEL DEFAULT(SHARED)
!$OMP DO PRIVATE(i, j), SCHEDULE(STATIC)
   DO i = 1, natom
	   dij(:,i) = 0.d0
      DO j = 1, natom
         ! alpha/rc*r(i,j) -alpha
         dij(j,i) = (beta_sub * pair_dist(j,i) ) - alpha_sub
      END DO
   END DO
!$OMP END DO
if(ipas==1) write(*,*) "mgo_coord:>alpha_sub and beta_sub",alpha_sub, beta_sub
!!write(*,*) "mgo_coord:> dist, dij(1,natom)",ipas,pair_dist(1,natom),dij(1,natom)

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! Elements on the diagonal
   DO i = 1, natom
      mgo_s(i,i) = 0.d0
	  mgo_dS(i,i) = 0.d0
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,gamma_sub), SCHEDULE(DYNAMIC,20)
   DO i = 1, natom-1
      DO j = i+1, natom
            gamma_sub = exp(dij(j,i))
            gamma_sub_1 = gamma_sub + 1.d0
			gamma_sub_2 = gamma_sub /(gamma_sub_1 * gamma_sub_1)
			!! for large cluster the pair distance may grow up and become very
			!! large (too large) for large value the addition of 1 change little or nothing, gamma_sub_1 ~ gamma_sub ->
			!gamma_sub_2 ~ 1/ gamma_sub
		    if(dij(j,i)>=80.d0) gamma_sub_2 = 1.d0 / gamma_sub
           ! The sum of these s(i,j) is the analytic coord no.
            mgo_s(j,i) = 1.d0/(gamma_sub + 1.d0)
            mgo_s(i,j) = mgo_s(j,i)

            ! Derivative of s w.r.t r(i,j)
            ! Use beta_sub or beta_sub_angstrom to have arete(1) or Angstrom as units
            mgo_dS(j,i) = -beta_sub_angstrom * gamma_sub_2
            mgo_dS(i,j) = mgo_dS(j,i)

      END DO ! on j
	  !!write(500,'(a25,2i4,4e13.5)') 'mgo_coord:> atom j=60',ipas, i, dij(60,i), gamma_sub, gamma_sub_1, mgo_dS(60,i)
   END DO ! on i
!$OMP END DO
!!write(*,*) "mgo_coord:> mgo_s(1,natom) mgo_s(1,2)",mgo_s(1,natom),mgo_s(1,2)

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! LP: Calculating the sum of s(i,j), which is mgo_CN(i), global.
   ! This is the coord num of any single atom i
   ! No problem because s(i,i) is always zero
   DO i = 1, natom
      mgo_cn(i) = SUM(mgo_s(1:natom,i))
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,comfactor), SCHEDULE(STATIC)
   !-------------------------------------------------------------------------
   ! Calculating the sum on j of derivatives of s
   ! with respect to coordinates of every atoms
   DO i = 1, natom
      DO j = 1, natom
         IF (j .NE. i) THEN
            ! Calculating the derivative of coordination number to atom i
            ! multiplied for the derivative of distance between atoms i and j
            ! with respect to position atom i
            !
			!xyz_dist(1,j,i) = x(i)-x(j)
			!pair_dist(j,i) = sqrt((x(i)-x(j))^2 + on y + on z)
			!comfactor doesn't depend on i,j order
			!
            comfactor  = mgo_dS(j,i)/ pair_dist(j,i)
            df_dx(j,i) = comfactor * xyz_dist(1,j,i) ! order of indexes depends on the definition of xyz_dist
            df_dy(j,i) = comfactor * xyz_dist(2,j,i) ! order of indexes depends on the definition of xyz_dist
            df_dz(j,i) = comfactor * xyz_dist(3,j,i) ! order of indexes depends on the definition of xyz_dist
         ELSE
            df_dx(j,i) = 0.d0
            df_dy(j,i) = 0.d0
            df_dz(j,i) = 0.d0
         END IF
      END DO
	  !!write(501,*) 'mgo_coord:> force atom j=60',ipas, i, mgo_dS(60,i), df_dx(60,i)
   END DO
!$OMP END DO

!$OMP SECTIONS PRIVATE(i)
!$OMP SECTION
Do k = 1,natom
    ! No factor 2 here: this is derivative of cn(i) w.r.o. x(i), not total cn w.r.o. x(i)
  !sum over all j/=k and subtract df_dx(k,i)
	mgo_dcn_dx(k) = SUM(df_dx(1:natom, k))
   DO i = 1, natom
	   if(i/=k)  mgo_dcn_dx(k) = mgo_dcn_dx(k) - df_dx(k,i)
   END DO
 ENDDO
!$OMP SECTION
   DO k = 1, natom
     mgo_dcn_dy(k) = SUM(df_dy(1:natom, k))
    DO i = 1, natom
       if(i/=k)  mgo_dcn_dy(k) = mgo_dcn_dy(k) - df_dy(k,i)
     END DO
   END DO
!$OMP SECTION
DO k = 1, natom
    mgo_dcn_dz(k) = SUM(df_dz(1:natom, k))
   DO i = 1, natom
     if(i/=k)  mgo_dcn_dz(k) = mgo_dcn_dz(k) - df_dz(k,i)
   END DO
 END DO
!$OMP END SECTIONS
!$OMP END PARALLEL
!
!LP's implementation
!   DO i = 1, natom
      ! No factor 2 here: this is derivative of cn(i) w.r.o. x(i), not total cn w.r.o. x(i)
!      mgo_dcn_dx(i) = SUM(df_dx(1:natom, i))
!   END DO
!!$OMP SECTION
!!same on y and z
!DO i = 1, natom
!   ! No factor 2 here: this is derivative of cn(i) w.r.o. x(i), not total cn w.r.o. x(i)
!   mgo_dcn_dy(i) = SUM(df_dy(1:natom, i))
!END DO
!!$OMP SECTION
!DO i = 1, natom
   ! No factor 2 here: this is derivative of cn(i) w.r.o. x(i), not total cn w.r.o. x(i)
 !  mgo_dcn_dz(i) = SUM(df_dz(1:natom, i))
 !END DO
!!$OMP SECTION
!
!!$OMP END SECTIONS
!!$OMP END PARALLEL
   !---------------------------------------------------------------------------
   !t_end = OMP_GET_WTIME()                                     !>>> CPU_TIME
   !! Writing the cpu time for the subroutine                   !>>> CPU_TIME
   !WRITE(500,'(1I10, 4X, 1F10.8)') ipas, t_end -t_start        !>>> CPU_TIME
END SUBROUTINE mgo_coord


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module run_nml

  use definitions, only: wp

  implicit none

  integer           :: nlins               ! number of lines
  integer           :: ncols               ! number of columns
  integer           :: nlays               ! number of levels
  integer           :: nlays_oro           ! number of levels following the orography
  real(wp)          :: dy                  ! mesh size in y direction at sea level
  real(wp)          :: dx                  ! mesh size in x direction at sea level at the equator
  real(wp)          :: dtime               ! time step
  real(wp)          :: toa                 ! top of atmosphere
  real(wp)          :: sigma               ! vertical grid stretching parameter
  integer           :: run_span_hr         ! run span in hours
  real              :: t_init              ! epoch time stamp of the initialization
  integer           :: slow_fast_ratio     ! ratio of advective to sound time step
  real(wp)          :: semimajor           ! large halfaxis of the Earth
  real(wp)          :: semiminor           ! small halfaxis of the Earth
  real(wp)          :: re                  ! Earth radius
  logical           :: lrestart            ! switch for restart runs
  logical           :: lcorio              ! switch for the Coriolis force
  logical           :: lideal              ! switch for analytic test cases
  logical           :: l3dvar              ! switch for 3d-Var
  logical           :: l4dvar              ! switch for 4d-Var
  character(len=64) :: scenario            ! scenario for ideal runs
  character(len=64) :: run_id              ! ID of the model run
  real(wp)          :: p_0                 ! reference pressure
  real(wp)          :: omega               ! angular frequency of Earth rotation
  real(wp)          :: lapse_rate          ! lapse_rate within the troposphere
  real(wp)          :: surface_temp        ! the temperature at the surface
  real(wp)          :: tropo_height        ! the tropopause height
  real(wp)          :: inv_height          ! height where the temperature inversion begins
  real(wp)          :: t_grad_inv          ! temperature gradient above the inversion
  real(wp)          :: p_0_standard        ! reference pressure of the standard atmosphere
  real(wp)          :: gravity             ! average surface gravity value
  logical           :: llinear             ! switch to turn momentum advection on or off
  real(wp)          :: impl_weight         ! implicit weight of the pressure gradient
  real(wp)          :: partial_impl_weight ! partial derivatives new time step weight

  namelist /run/nlins,ncols,nlays,dy,dx,run_span_hr,sigma, &
  slow_fast_ratio,toa,scenario,llinear,run_id,lcorio,nlays_oro

  contains

  subroutine run_nml_setup

    ! local variables
    integer :: fileunit

    nlins               = 101
    ncols               = 101
    nlays               = 80
    dy                  = 800._wp
    dx                  = 850._wp
    run_span_hr         = 63
    t_init              = 0._wp
    slow_fast_ratio     = 1
    toa                 = 40000._wp
    sigma               = 1.3_wp
    semiminor           = 6356752.314_wp
    semimajor           = 6378137.0_wp
    re                  = (semimajor*semimajor*semiminor)**(1._wp/3._wp)
    lrestart            = .false.
    lideal              = .true.
    l3dvar              = .false.
    l4dvar              = .false.
    scenario            = "standard"
    run_id              = "ideal"
    p_0                 = 100000._wp
    omega               = 7.292115e-5
    lapse_rate          = 0.0065_wp
    surface_temp        = 288.15_wp
    tropo_height        = 12000._wp
    inv_height          = 20000._wp
    t_grad_inv          = 0.001_wp
    p_0_standard        = 101325._wp
    gravity             = 9.80616_wp
    llinear             = .false.
    lcorio              = .true.
    impl_weight         = 0.75_wp
    partial_impl_weight = 0.5_wp

    ! Open and read Namelist file.
    open(action="read", file="namelist.nml", newunit=fileunit)
    read(nml=run, unit=fileunit)

    close(fileunit)

    ! this calculates the time step using the CFL criterion
    dtime           = 1.5_wp*dy/1000._wp

    ! checking input data for correctness
    if (mod(nlins, 2) == 0) then
      write(*,*) "Error: nlins must be odd. Aborting."
      call exit(1)
    endif
    if (mod(ncols, 2) == 0) then
      write(*,*) "Error: ncols must be odd. Aborting."
      call exit(1)
    endif
    if (toa <= 0) then
      write(*,*) "Error: TOA must be positive."
      call exit(1)
    endif

    write(*,*) "Time step: ", dtime, " s."

  end subroutine run_nml_setup

end module run_nml


program printNum
    implicit none
    !printing numbers from 11 to 20
    integer::n,nfact=1,i,j,k
    do n=11,20
        print *,n
    end do

    !factorials
    do n=1,10
        nfact=nfact*n
        print *,n," ",nfact
    end do

    !factorials using do while loop
    n=1
    nfact=1
    do while(n<=10)
        nfact=nfact*n
        print *,n," ",nfact
        n=n+1
    end do

    !nested loops example
    iloop: do i=1,3
    jloop: do j=1,3
    kloop: do k=1,3

        print*,"(i,j,k) : ",i,j,k

        !using exit statement
        if(k==2) then
            exit jloop !using exit statement just like break in c++
        end if
           end do kloop
           end do jloop
           end do iloop

    !using cycle statement just like continue in c++
    do i=1,20
        if(i==5) then
            cycle
        end if
        print*,i
    end do

    !using stop statement just like exit in c++
    do i=1,20
        if(i==5) then
            stop
        end if
        print*,i
    end do

end program


      SUBROUTINE CNORM(X,DIV,Y)
C
C     CNORM WILL NORMALIZE X TO THE MAXIMUM ELEMENT EQUAL TO A MODULUS
C     OF ONE AND STORE THE DIVISOR IN MAX (X MAY BE COMPLEX)
C
      DOUBLE PRECISION X(1),DIV(2),MAX,TEMP,Y(1),SIGN,COSANG,XO,D,R,RI
      COMMON /SYSTEM/  IBUF,NOUT
      COMMON /CINVPX/  FILEK(7)
      COMMON /CINVXX/  DUM(30),IND1,ITER
      EQUIVALENCE      (NCOL,FILEK(2))
C
      NCOL2 = NCOL + NCOL
      MAX   = 0.D0
      SIGN  = 1.0D0
      IND   = 0
      DO 20 I = 1,NCOL2,2
      IF (X(I)**2+X(I+1)**2 .LE. MAX) GO TO 20
      MAX = X(I)**2 + X(I+1)**2
      IND = I
   20 CONTINUE
      IF (IND  .EQ.   0) GO TO 80
      IF (ITER .EQ.   1) GO TO 60
      IF (IND .EQ. IND1) GO TO 50
      CALL SSWTCH (12,IDIAG)
      IF (IDIAG .EQ.  0) GO TO 40
      WRITE  (6,30) IND,IND1
   30 FORMAT (10H CHANGE     ,2I5)
   40 CONTINUE
   50 CONTINUE
      D  = X(IND)**2 + X(IND+1)**2
      R  = (X(IND1)*X(IND) + X(IND1+1)*X(IND+1))/D
      RI = (X(IND1+1)*X(IND) - X(IND1)*X(IND+1))/D
      COSANG = XO*R/DSQRT(R**2 + RI**2)
      IF (DABS(COSANG+1.D0) .LE. 0.1D0) SIGN = -1.0D0
   60 I  = IND
      DIV(1) = X(I  )*SIGN
      DIV(2) = X(I+1)*SIGN
      IND1 = IND
      MAX  = 1.0D0/MAX
      DO 70 I = 1,NCOL2,2
      TEMP   = (X(I)*DIV(1)+X(I+1)*DIV(2))*MAX
      X(I+1) = (X(I+1)*DIV(1)-X(I)*DIV(2))*MAX
   70 X(I) = TEMP
      XO = X(IND)
      RETURN
C
   80 WRITE  (NOUT,90)
   90 FORMAT (//5X,37HCONOR  RECEIVED A VECTOR OF ALL ZEROS)
      CALL MESAGE (-37,0,0)
      RETURN
      END