      SUBROUTINE sp_bess_i( x, n, val )
      IMPLICIT NONE
      DOUBLE PRECISION X, BI(2001), BK(2001), VAL
      INTEGER N, NMAX, NUEVO
      NMAX = N + 1
      CALL BESSIMSE( X, NMAX, BI, BK, NUEVO )
      VAL = BI(NUEVO)
      END

      SUBROUTINE bessimse (x,Nmax,bi,bk,nuevo)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc Modified Bessel functions of the first and second kinds (half-integral)  cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c                                                                            c
cc INPUT:  x-->argument / Nmax-->maximum order of the Bessel functions      cc
c                                                                            c
cc OUTPUT: bi(l+1)-->mbf of the first kind of order l (array)               cc
c          bk(l+1)-->mbf of the second kind of order l  (array)              c
c        nuevo--> max. order of bf's calculated when bk(Nmax+1,x)>10**expma  c
c                                                                            c
c  PARAMETERS: eps->control of accuracy in the continued fraction            c
c              mode->when mode=1 (0) exp(+-x) is (not) factored out          c
c              expma-> overflow/underflow numbers = 10**(+-expma)            c
c                                                                            c
c CALLS: slimit(x,expma,mode,Nmax,nuevo)--> evaluates the max. order (nuevo) c
c                                                                            c
cc NOTE: this code is for real positive x and Nmax less than 2000           cc
c        Double precission accuracy                                          c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      IMPLICIT REAL*8 (a-h,o-z)
      INTEGER MODE
      DIMENSION bi(2001),bk(2001)

       PARAMETER(pi=3.14159265358979323D0,mode=0,eps=1.D-16,
     + expma=300.)

cccccccccccccccccccccccccccccccccc
c   we use the code if Nmax>=2   c
cccccccccccccccccccccccccccccccccc

      nuevo = Nmax
      nmaxp=Nmax
      IF(Nmax.LT.2) Nmax=2

cccccccccccccccccccccccccccccccccccccc
c slimit evaluates the maximum order c
c that can be calculated, avoiding   c
c overflows.                         c
c comment the following line         c
c when not needed                    c
cccccccccccccccccccccccccccccccccccccc

      CALL slimit(x,expma,mode,Nmax,nuevo)

      Nmax=nuevo

ccccccccccccccccccccccccccccccccc
c   values of bk(1) and bk(2)   c
ccccccccccccccccccccccccccccccccc

      xinv = 1./x
      xinv2=xinv*xinv
      IF(MODE.eq.0)then
          xk0 = xinv*DEXP(-x)
          xk1 = (xinv + xinv2 )*DEXP(-x)
      ELSE
          xk0=xinv
          xk1= (xinv+xinv2)
      ENDIF
      bk(1) = xk0*0.5D0*pi
      bk(2) = xk1*0.5D0*pi

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c   upward recurrence relations for bk(l+1) l= 2,3,4,...,Nmax  c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      DO 7 np=2,Nmax
          n=np-1
          bk(np+1)=DFLOAT(n+n+1)*bk(np)*xinv+bk(n)
   7  CONTINUE

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c   c.f.  ( Steed's algorithm ) to calculate h = bi(Nmax+1)/bi(Nmax)     c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      n=Nmax
      d=x/DFLOAT(n+n+1)
      del=d
      h=del
      b=DFLOAT(n+n+3)*xinv
   8  d=1.D0/(b+d)
      del=(b*d-1.D0)*del
      h=h+del
      b=b+2.d0*xinv
      IF(ABS(del/h).GT.eps) GO TO 8

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     we evaluate bi(Nmax+1) and bi(Nmax) using :                         c
c     the Wronskian : w{bi(Nmax),bi(Nmax)} =-0.5*pi/x**2                  c
c     the known values of bi(Nmax+1) and bk(Nmax)                         c
c     the value of h = bi(Nmax+1)/bi(Nmax)                                c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      bi(Nmax)=0.5D0*pi/(x*x*(h*bk(Nmax)+bk(Nmax+1)))
      bi(Nmax+1)=h*bi(Nmax)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c downward recurrence relations for bi(l+1) l= Nmax-2,Nmax-3,..,2,1,0  c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      DO 9 i=2,Nmax
          np=Nmax+2-i
          n=np-1
          bi(n)=DFLOAT(n+n+1)*bi(np)*xinv+bi(np+1)
   9  CONTINUE
      Nmax=nmaxp
      RETURN
      END

       SUBROUTINE slimit(x,expma,mode,Nmax,nuevo)
       IMPLICIT REAL*8 (a-h,o-z)
       INTEGER nuevo
cccccccccccccccccccccccccccccccccccccccccc
c   limits to the value of Nmax = nuevo  c
c   bk(nuevo+1,x)<10**expma              c
cccccccccccccccccccccccccccccccccccccccccc
      fcmax=expma*LOG(10.)
      fc=fcmax+1.
      fn=DFLOAT(Nmax)+0.5
      DO WHILE(fc.GT.fcmax)
          alfn=LOG(2.*fn)
          IF(mode.EQ.0)THEN
              fc=(fn-0.5)*alfn-fn-(fn+0.5)*LOG(x)
          ELSE
              fnx=SQRT(fn*fn+x*x)
              fc=fn*LOG(fn+fnx)-0.5*alfn-fnx-(fn+0.5)*LOG(x)+x
          ENDIF

          fn=fn-3.
      ENDDO
      fn=fn+3.
      nuevo = INT(fn)
      RETURN
      END
c----------
cc       bessimin.f
      SUBROUTINE bessimin(x,Nmax,bi,bk,nuevo)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc   Modified Bessel Functions of the first and second kind (integer)      cc
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc INPUT:  x-->argument / Nmax--> maximum order of the  mbf's              cc
c             eps-->control of the accuracy in the c.f.                     c
c                                                                           c
cc OUTPUT: bi(l+1)-->mbf of the first kind of order l (array)              cc
c          bk(l+1)-->mbf of the second kind of order l (array               c
c         nuevo-->maxi. order mbf's calculated when bk(Nmax+1,x)>10**expma  c
c                                                                           c
c  PARAMETERS: eps-->control of the accuracy in the c.f.                    c
c              mode-->when mode=1 (0) exp(+-x) is (not) factored out        c
c              expma-->overflow/undeflow numbers=10**(+-expma)              c
c                                                                           c
c  CALLS: limit(x,expma,mode,Nmax,nuevo)-> evaluate the max. order (nuevo)  c
c          bessim01(x,mode,xk0,xk1)-> evaluates K(0) and K(1)               c
c                                                                           c
cc NOTE :this version of the code is for real x>0 and Nmax less than 2000  cc
c        the precission is limited by the accuracy in the calculation of    c
c        K(0) (bk(1)) and K(1) (bk(2)); prec= 2.d-7 for bessim01            c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      IMPLICIT REAL*8 (a-h,o-z)
      INTEGER MODE
      DIMENSION bi(2001),bk(2001)
      PARAMETER(pi=3.14159265358979323D0,mode=0,eps=1.D-8,
     + expma=300.D0)

cccccccccccccccccccccccccccccccccc
c   we use the code if Nmax>=2   c
cccccccccccccccccccccccccccccccccc

      nuevo = Nmax
      nmaxp=Nmax
      IF(Nmax.LT.2) Nmax=2

cccccccccccccccccccccccccccccccccccccc
c limit evaluates the maximum order  c
c that can be calculated, avoiding   c
c overflows.                         c
c comment the following line         c
c when not needed                    c
cccccccccccccccccccccccccccccccccccccc

      CALL limit(x,expma,mode,Nmax,nuevo)

      Nmax=nuevo

cccccccccccccccccccccccccccccccccc
c   values of bk(1) and bk(2)    c
cccccccccccccccccccccccccccccccccc

      CALL  bessim01(x,mode,xk0,xk1)

      bk(1) = xk0
      bk(2) = xk1

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c   upward recurrence relations for  bk(l+1) l= 2,3,4,...,Nmax   c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      xinv=1.0D0/x
      DO 7 np=2,Nmax
          n=np-1
          bk(np+1)=DFLOAT(n+n)*bk(np)*xinv+bk(n)
   7  CONTINUE

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c   c.f. (Steed's) to calculate h = bi(Nmax+1)/bi(Nmax)  c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      n=Nmax
      d=x/DFLOAT(n+n)
      del=d
      h=del
      b=2.d0*DFLOAT(n+1)*xinv
  8   d=1.d0/(b+d)
      del=(b*d-1.D0)*del
      h=h+del
      b=b+2.D0*xinv
      IF(ABS(del/h).GT.eps) GO TO 8

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     we evaluate bi(Nmax+1) and bi(Nmax) using :               c
c     the Wronskian : W{bi(Nmax),bk(Nmax)} = 2./pi/x            c
c     the known values of bk(Nmax+1) and bk(Nmax)               c
c     the value of h = bi(Nmax+1)/bi(Nmax)                      c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      bi(Nmax+1)=xinv/(bk(Nmax)+bk(Nmax+1)/h)
      bi(Nmax)=bi(Nmax+1)/h

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c   downward recurrence relations for bi(l+1) l= Nmax-2,Nmax-3,..,2,1,0    c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      DO 9 i=2,Nmax
          np=Nmax+2-i
          n=np-1
          bi(n)=DFLOAT(n+n)*bi(np)*xinv+bi(np+1)
   9  CONTINUE
      Nmax=nmaxp
      RETURN
      END

       SUBROUTINE limit(x,expma,mode,Nmax,nuevo)
       IMPLICIT REAL*8 (a-h,o-z)
       INTEGER nuevo
cccccccccccccccccccccccccccccccccccccccccc
c   limits to the value of Nmax = nuevo  c
c   bk(nuevo+1,x)<10**expma              c
cccccccccccccccccccccccccccccccccccccccccc
      fcmax=expma*LOG(10.)
      fc=fcmax+1.
      fn=DFLOAT(Nmax)
      DO WHILE(fc.GT.fcmax)
          alfn=LOG(2.*fn)
          IF(mode.EQ.0)THEN
              fc=(fn-0.5)*alfn-fn-fn*LOG(x)
          ELSE
              fnx=SQRT(fn*fn+x*x)
              fc=fn*LOG(fn+fnx)-0.5*alfn-fnx-fn*LOG(x)+x
          ENDIF

          fn=fn-3.
      ENDDO
      fn=fn+3.
      nuevo = INT(fn)
      RETURN
      END

      SUBROUTINE bessim01(x,mode,k0,k1)
      IMPLICIT REAL*8 (a-h,o-z)
      REAL*8 k0,k1,i0,i1
      SAVE a1,a2,a3,a4,a5,a6,a7
      SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
      SAVE c1,c2,c3,c4,c5,c6,c7
      SAVE r1,r2,r3,r4,r5,r6,r7,s1,s2,s3,s4,s5,s6,s7
      DATA a1,a2,a3,a4,a5,a6,a7/1.0D0,3.5156229D0,3.0899424D0,
     + 1.2067492D0,0.2659732D0,0.360768D-1,0.45813D-2/
      DATA p1,p2,p3,p4,p5,p6,p7/-0.57721566D0,0.42278420D0,
     + 0.23069756D0,0.3488590D-1,0.262698D-2,0.10750D-3,0.74D-5/
      DATA q1,q2,q3,q4,q5,q6,q7/1.25331414D0,-0.7832358D-1,
     + 0.2189568D-1,-0.1062446D-1,0.587872D-2,-0.251540D-2,
     + 0.53208D-3/
      DATA c1,c2,c3,c4,c5,c6,c7/0.5D0,0.87890594D0,0.51498869D0,
     + 0.15084934D0,0.2658733D-1,0.301532D-1,0.32411D-3/
      DATA r1,r2,r3,r4,r5,r6,r7/1.0D0,0.15443144D0,-0.67278579D0,
     + -0.18156897D0,-0.1919402D-1,-0.110404D-2,-0.4686D-4/
      DATA s1,s2,s3,s4,s5,s6,s7/1.25331414D0,0.23498619D0,
     + -0.3655620D-1,0.1504268D-1,-0.780353D-2,0.325614D-2,
     + -0.68245D-3/

       IF(x.LE.2.0)THEN
           y=(x/3.75)**2
           i0=a1+y*(a2+y*(a3+y*(a4+y*(a5+y*(a6+y*a7)))))
           i1=x*(c1+y*(c2+y*(c3+y*(c4+y*(c5+y*(c6+y*c7))))))
           y=x*x/4.0
           fac2=LOG(x/2.0)
           IF(mode.EQ.1)THEN
              fac3=EXP(x)
           ELSE
              fac3=1.
           ENDIF
           k0=fac3*((-fac2*i0)+(p1+y*(p2+y*(p3+y*(p4+y*(
     +     p5+y*(p6+y*p7)))))))
           k1=fac3*((fac2*i1)+(1.0/x)*(r1+y*(r2+y*(r3+y*(
     +     r4+y*(r5+y*(r6+y*r7)))))))
       ELSE
           y=2.0/x
           IF(mode.EQ.0)THEN
               fac3=EXP(-x)/SQRT(x)
           ELSE
               fac3=1/SQRT(x)
           ENDIF
           k0=fac3*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(
     +     q6+y*q7))))))
           k1=fac3*(s1+y*(s2+y*(s3+y*(s4+y*(s5+y*(
     +     s6+y*s7))))))
       ENDIF

       RETURN
       END
c$$$c----------
c$$$cc      testpro.f
c$$$       PROGRAM test
c$$$       IMPLICIT REAL*8 (a-h,o-z)
c$$$       DIMENSION bi(2001),bk(2001)
c$$$
c$$$       x = 2.5d0
c$$$       Nmax = 3
c$$$       CALL bessimse(x,Nmax,bi,bk,nuevo)
c$$$       DO 101 I = 1, nuevo
c$$$          PRINT*, I, bi(I), bk(I)
c$$$ 101   CONTINUE
c$$$
c$$$       x = 2.5d0
c$$$       n = 2
c$$$       CALL sp_bess_i( 2.5d0, 2, val )
c$$$       PRINT*, val
c$$$
c$$$       END
c$$$
c$$$


program test_ffte
use types, only: dp
use fourier, only: dft, idft, fft, fft_vectorized, fft_pass, fft_pass_inplace, &
        fft_vectorized_inplace, calculate_factors, ifft_pass, fft2_inplace, &
        fft3_inplace, ifft3_inplace
use utils, only: assert, init_random
use ffte, only: ffte_fft3_inplace => fft3_inplace, &
    ffte_ifft3_inplace => ifft3_inplace
use openmp, only: omp_get_wtime
implicit none

complex(dp), allocatable :: x3(:, :, :), x3d(:, :, :)
real(dp) :: tmp
real(dp) :: t1, t2
integer :: l, m, n, i, j, k

allocate(x3(3, 5, 8))
forall(i=1:size(x3, 1), j=1:size(x3, 2), k=1:size(x3, 3))
    x3(i, j, k) = i*j+3*i**2+k*j+k
end forall
call fft3_inplace(x3)
call assert(abs(sum(x3)-720) < 1e-9_dp)

forall(i=1:size(x3, 1), j=1:size(x3, 2), k=1:size(x3, 3))
    x3(i, j, k) = i*j+3*i**2+k*j+k
end forall
call ffte_fft3_inplace(x3)
call assert(abs(sum(x3)-720) < 1e-9_dp)
deallocate(x3)

print *, "fft3 l m n:"
l = 15
m = 16
n = 20
allocate(x3(l, m, n), x3d(l, m, n))
do i = 1, size(x3, 1)
do j = 1, size(x3, 2)
do k = 1, size(x3, 3)
    call random_number(tmp)
    x3(i, j, k) = tmp
end do
end do
end do
x3d = x3
call cpu_time(t1)
call ffte_fft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call cpu_time(t1)
call ifft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/(l*m*n)) < 5e-15_dp))
x3d = x3
call cpu_time(t1)
call fft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call cpu_time(t1)
call ffte_ifft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/(l*m*n)) < 5e-15_dp))
deallocate(x3, x3d)

print *, "fft3:"
n = 16
allocate(x3(n, n, n), x3d(n, n, n))
do k = 1, size(x3, 3)
do j = 1, size(x3, 2)
do i = 1, size(x3, 1)
    call random_number(tmp)
    x3(i, j, k) = tmp
end do
end do
end do
x3d = x3
t1 = omp_get_wtime()
call ffte_fft3_inplace(x3d)
t2 = omp_get_wtime()
print *, "time:", (t2-t1)*1000, "ms"
t1 = omp_get_wtime()
call ifft3_inplace(x3d)
t2 = omp_get_wtime()
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/n**3) < 5e-15_dp))
x3d = x3
t1 = omp_get_wtime()
call fft3_inplace(x3d)
t2 = omp_get_wtime()
print *, "time:", (t2-t1)*1000, "ms"
t1 = omp_get_wtime()
call ffte_ifft3_inplace(x3d)
t2 = omp_get_wtime()
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/n**3) < 5e-15_dp))
deallocate(x3, x3d)

end program


! Created by  on 02.05.20.

module quantum
    implicit none
contains
    function principal_quantum_number(res) result(n_max)
        implicit none
        real :: res, tmp_res = 0
        integer :: i = 0, j, n_max
        do while (tmp_res<=res)
            j = i - 2
            do while (j>=1 .or. j>=0)
                tmp_res = tmp_res + 2 * j + 1
                if (tmp_res>res) exit
                j = j - 2
            end do
            i = i + 1
        end do
        n_max = i
    end function principal_quantum_number

    function azimuthal_quantum_number(res, n_max) result(l_max)
        implicit none
        real :: res, tmp_res, tmp_res1 = 0, tmp_res2 = 0, diff1, diff2
        integer :: i = 0, q = 0, w = 1, j, n_max, l_max
        do i = 0, n_max
            if (i==n_max) then
                tmp_res1 = tmp_res
                do while(tmp_res1<res)
                    tmp_res1 = tmp_res1 + 2 * q + 1
                    if (tmp_res1 >res) then
                        exit
                    end if
                    q = q + 2
                end do
                tmp_res2 = tmp_res
                do while(tmp_res2<res)
                    tmp_res2 = tmp_res2 + 2 * w + 1
                    if (tmp_res2 >res) then
                        exit
                    end if
                    w = w + 2
                end do
                diff1 = abs(tmp_res1 - res)
                diff2 = abs(tmp_res2 - res)
                if (diff2>diff1) then
                    l_max = q
                else
                    l_max = w
                end if
                exit
            end if
            j = i - 2
            do while(j>=0 .or. j>=1)
                tmp_res = tmp_res + 2 * j + 1
                j = j - 2
            end do
        end do
    end function azimuthal_quantum_number

    function improve_radius(rs, bor_radius, l_max, n_max) result(radius)
        implicit none
        real :: rs, bor_radius, radius
        integer :: i, j, l_max, n_max, total_quantum = 0
        do i = 0, n_max
            if (i==n_max) then
                j = l_max - 2
                do while(j>=0 .or. j>=1)
                    total_quantum = total_quantum + 2 * j + 1
                    j = j - 2
                end do
                exit
            end if
            j = i - 2
            do while(j>=0 .or. j>=1)
                total_quantum = total_quantum + 2 * j + 1
                j = j - 2
            end do
        end do
        radius = (total_quantum * rs**3 * bor_radius**3)**(1.0 / 3.0)
    end function improve_radius

    subroutine quantum_numbers(R, rs, bor_radius, l_max, n_max, defined_radius)
        implicit none
        real, intent(in) :: R, rs, bor_radius
        integer, intent(out) :: l_max, n_max
        integer :: i = 0, j = 0, tmp_res = 0
        real :: left_res
        real, intent(out) :: defined_radius
        left_res = R**3 / (rs**3 * bor_radius**3)
        n_max = principal_quantum_number(left_res)
        l_max = azimuthal_quantum_number(left_res, n_max)
        defined_radius = improve_radius(rs, bor_radius, l_max, n_max)
    end subroutine quantum_numbers
end module quantum


PROGRAM test_longlog_longexp
! Tests:
! 1. log(x^2) = 2.*log(x)
! 2. e^(2x)   = (e^x)**2

USE quadruple_precision
IMPLICIT NONE

TYPE (quad)          :: x, lhs, rhs, diff
INTEGER, ALLOCATABLE :: seed(:)
INTEGER              :: k, i
REAL (dp)            :: half = 0.5_dp, small = 1.e-16_dp

!     Set the random number seed.

CALL RANDOM_SEED(size=k)
ALLOCATE (seed(k))
CALL RANDOM_SEED(get=seed)
WRITE(*, *)'Old random number seeds: ', seed

WRITE(*, '(1x, a, i4, a)') 'Enter ', k, ' integers as random number seeds: '
READ(*, *) seed
CALL RANDOM_SEED(put=seed)

DO i = 1, 10
  CALL RANDOM_NUMBER(x%hi)
  x%hi = (x%hi - half) / x%hi
  x%lo = x%hi * small
                                       ! log(x^2) = 2.*log(x)
  lhs = LOG(x * x)
  IF (x%hi > 0._dp) THEN
    rhs = LOG(x)
  ELSE
    rhs = LOG(-x)
  END IF
  rhs = 2._dp * rhs
  diff = lhs - rhs
  WRITE(*, '(" lhs =", g13.5, "  Diff. =", g12.4)') lhs%hi, diff%hi
                                       ! e^(2x) = (e^x)**2
  lhs = 2._dp * x
  lhs = EXP(lhs)
  rhs = EXP(x)
  rhs = rhs * rhs
  diff = lhs - rhs
  WRITE(*, '(" lhs =", g13.5, "  Diff. =", g12.4)') lhs%hi, diff%hi
END DO

STOP
END PROGRAM test_longlog_longexp


! { dg-do run }
!
! PR fortran/52151
!
! Check that the bounds/shape/strides are correctly set
! for (re)alloc on assignment, if the LHS is either not
! allocated or has the wrong shape. This test is for
! code which is only invoked for libgfortran intrinsic
! such as RESHAPE.
!
! Based on the example of PR 52117 by Steven Hirshman
!
    PROGRAM RESHAPEIT
      call unalloc ()
      call wrong_shape ()
    contains
    subroutine unalloc ()
      INTEGER, PARAMETER :: n1=2, n2=2, n3=2
      INTEGER            :: m1, m2, m3, lc
      REAL, ALLOCATABLE  :: A(:,:), B(:,:,:)
      REAL               :: val

      ALLOCATE (A(n1,n2*n3))
! << B is not allocated

      val = 0
      lc = 0
      DO m3=1,n3
         DO m2=1,n2
            lc = lc+1
            DO m1=1,n1
               val = val+1
               A(m1, lc) = val
            END DO
         END DO
      END DO

      B = RESHAPE(A, [n1,n2,n3])

      if (any (shape (B)  /= [n1,n2,n3])) STOP 1
      if (any (ubound (B) /= [n1,n2,n3])) STOP 2
      if (any (lbound (B) /= [1,1,1])) STOP 3

      lc = 0
      DO m3=1,n3
         DO m2=1,n2
            lc = lc+1
            DO m1=1,n1
!               PRINT *,'A(',m1,',',lc,') = ',A(m1,lc),' B = ',B(m1,m2,m3)
               if (A(m1,lc) /= B(m1,m2,m3)) STOP 4
            END DO
         END DO
      END DO
      DEALLOCATE(A, B)
    end subroutine unalloc

    subroutine wrong_shape ()
      INTEGER, PARAMETER :: n1=2, n2=2, n3=2
      INTEGER            :: m1, m2, m3, lc
      REAL, ALLOCATABLE  :: A(:,:), B(:,:,:)
      REAL               :: val

      ALLOCATE (A(n1,n2*n3))
      ALLOCATE (B(1,1,1))     ! << shape differs from RHS

      val = 0
      lc = 0
      DO m3=1,n3
         DO m2=1,n2
            lc = lc+1
            DO m1=1,n1
               val = val+1
               A(m1, lc) = val
            END DO
         END DO
      END DO

      B = RESHAPE(A, [n1,n2,n3])

      if (any (shape (B)  /= [n1,n2,n3])) STOP 5
      if (any (ubound (B) /= [n1,n2,n3])) STOP 6
      if (any (lbound (B) /= [1,1,1])) STOP 7

      lc = 0
      DO m3=1,n3
         DO m2=1,n2
            lc = lc+1
            DO m1=1,n1
!               PRINT *,'A(',m1,',',lc,') = ',A(m1,lc),' B = ',B(m1,m2,m3)
               if (A(m1,lc) /= B(m1,m2,m3)) STOP 8
            END DO
         END DO
      END DO
      DEALLOCATE(A, B)
    end subroutine wrong_shape
    END PROGRAM RESHAPEIT


program guass

use correlation
use bootstrap

implicit none

integer :: i,j,n,m
real, allocatable :: x(:),y(:),tx(:),ty(:)
real :: r(3),tmp1,tmp2
character*255 :: f1,f2

print *,'Citation'
print *,'Roberts et al. (2016), Correlation confidence limits for unevenly sampled data, Computers & Geosciences'
print *
print *,'Enter filename of first data series'
read *,f1
print *,'Enter filename of second data series'
read *,f2

open(11,file=trim(f1),form="formatted")
n=0
do
  read (11,*,end=10,err=10)tmp1,tmp2
  n=n+1
enddo
10 close(11)

open(11,file=trim(f2),form="formatted")
m=0
do
  read (11,*,end=20,err=20)tmp1,tmp2
  m=m+1
enddo
20 close(11)

allocate (x(n),tx(n),y(m),ty(m))

open(11,file=trim(f1),form="formatted")
do i=1,n
  read(11,*)tx(i),x(i)
enddo
close(11)

open(11,file=trim(f2),form="formatted")
do i=1,m
  read(11,*)ty(i),y(i)
enddo
close(11)

r(1)=correlate_gaussian(x(1:n),y(1:m),tx(1:n),ty(1:m))
r(2:3)=bootstrap_ci(x(1:n),y(1:m),tx(1:n),ty(1:m))
print *,r(1),'[',r(2),":",r(3),"]"

deallocate (x,tx,y,ty)

end program


! Learn_dg - A quick and dirty project to deploy a working DG solver
! Copyright (c) 2017, Chris Coutinho
! All rights reserved.
!
! Licensed under the BSD-2 clause license. See LICENSE for details.

program driver1D
    use, intrinsic :: iso_fortran_env, only: wp=>real64
    use :: mod_linalg,    only: linsolve_quick
    use :: mod_misc,      only: r8mat_print
    use :: mod_io,        only: read_gmsh_file_1D, write_out_solution
    use :: mod_assembly,  only: initialize_global_mats, assemble, set_BCs

    implicit none

    real(wp), parameter                   :: diff = 0.1_wp, vel = -5._wp

    integer                               :: num_nodes
    integer,  dimension(:),   allocatable :: nodes2vertex
    integer,  dimension(:,:), allocatable :: cells
    real(wp), dimension(:),   allocatable :: points, GlobalB, GlobalX
    real(wp), dimension(:,:), allocatable :: GlobalA
    logical                               :: dg

    ! dg = .true.
    dg = .false.

    call read_gmsh_file_1D(num_nodes, nodes2vertex, cells, points, dg)
    ! stop

    call initialize_global_mats(num_nodes, GlobalA, GlobalB, GlobalX)

    call assemble(points, cells, diff, vel, GlobalA)

    call set_BCs(points, GlobalB, GlobalA)

    ! call r8mat_print(num_nodes, num_nodes, GlobalA, 'Global Stiffness matrix:')
    ! stop

    call linsolve_quick(num_nodes, GlobalA, 1, GlobalB, GlobalX)
    ! call r8mat_print(num_nodes, 1, GlobalB, 'Global RHS:')
    ! call r8mat_print(num_nodes, 1, GlobalX, 'Global Solution Vector:')

    call write_out_solution(num_nodes, points, GlobalX)

end program driver1D


! email: personal@auliakhalqillah.com
program bilangangenap
    implicit none
    integer :: i,n
    real :: xeven

    write(*,*) 'Bilangan Genap'
    n = 10 ! banyak data
    xeven = 2 ! inisial bilangan genap
    do i = 1,n
        write(*,*) xeven
        xeven = xeven + 2
    end do

end program


MODULE Knuth_random

! Code converted using TO_F90 by Alan Miller
! Date: 2000-09-10  Time: 16:37:48
! Latest revision - 16 January 2003

! FORTRAN 77 version of "ran_array"
! from Seminumerical Algorithms by D E Knuth, 3rd edition (1997)
!       including the MODIFICATIONS made in the 9th printing (2002)
! ********* see the book for explanations and caveats! *********
! Author: Steve Kifowit
! http://ourworld.compuserve.com/homepages/steve_kifowit
! with modifications by Alan Miller to rnarry and rnstrt based upon
! Knuth's code.

! For Donald Knuth's Fortran 77 versions, go to:
! http://www-cs-faculty.stanford.edu/~knuth/programs
! Look for frng.f and frngdb.f

IMPLICIT NONE
INTEGER, PARAMETER  :: kk=100, ll=37, mm=2**30, tt=70, kkk=kk+kk-1
INTEGER, SAVE       :: ranx(kk)

CONTAINS

SUBROUTINE rand(u, n)

! Generate an array of n real values between 0 and 1.

REAL, INTENT(OUT)    :: u(:)
INTEGER, INTENT(IN)  :: n

! Local array
INTEGER  :: aa(n)

CALL rnarry(aa, n)
u(1:n) = SCALE( REAL(aa), -30)

RETURN
END SUBROUTINE rand

SUBROUTINE rnarry(aa, n)

! Generate an array of n integers between 0 and 2^30-1.

INTEGER, INTENT(OUT)  :: aa(:)
INTEGER, INTENT(IN)   :: n

! Local variables
INTEGER  :: j

aa(1:kk) = ranx(1:kk)
DO  j = kk + 1, n
  aa(j) = aa(j-kk) - aa(j-ll)
  IF (aa(j) < 0) aa(j) = aa(j) + mm
END DO
DO  j=1,ll
  ranx(j) = aa(n+j-kk) - aa(n+j-ll)
  IF (ranx(j) < 0) ranx(j) = ranx(j) + mm
END DO
DO  j=ll+1,kk
  ranx(j) = aa(n+j-kk) - ranx(j-ll)
  IF (ranx(j) < 0) ranx(j) = ranx(j) + mm
END DO

RETURN
END SUBROUTINE rnarry

SUBROUTINE rnstrt(seed)

! Initialize integer array ranx using the input seed.

INTEGER, INTENT(IN)  :: seed

! Local variables
INTEGER  :: x(kkk), j, ss, sseed, t

IF (seed < 0) THEN
  sseed = mm - 1 - MOD(-1-seed, mm)
ELSE
  sseed = MOD(seed, mm)
END IF
ss = sseed - MOD(sseed,2) + 2
DO  j=1, kk
  x(j) = ss
  ss = ISHFT(ss, 1)
  IF (ss >= mm) ss = ss - mm + 2
END DO
x(kk+1:kkk) = 0
x(2) = x(2)+1
ss = sseed
t = tt - 1
10 DO  j=kk, 2, -1
  x(j+j-1) = x(j)
END DO
DO  j = kkk, kk + 1, -1
  x(j-(kk-ll)) = x(j-(kk-ll)) - x(j)
  IF (x(j-(kk-ll)) < 0) x(j-(kk-ll)) = x(j-(kk-ll)) + mm
  x(j-kk) = x(j-kk) - x(j)
  IF (x(j-kk) < 0) x(j-kk) = x(j-kk) + mm
END DO
IF (MOD(ss,2) == 1) THEN
  DO  j=kk, 1, -1
    x(j+1) = x(j)
  END DO
  x(1) = x(kk+1)
  x(ll+1) = x(ll+1) - x(kk+1)
  IF (x(ll+1) < 0) x(ll+1) = x(ll+1) + mm
END IF
IF (ss /= 0) THEN
  ss = ISHFT(ss, -1)
ELSE
  t = t - 1
END IF
IF (t > 0) GO TO 10

DO  j=1, ll
  ranx(j+kk-ll) = x(j)
END DO
DO  j=ll+1,kk
  ranx(j-ll) = x(j)
END DO

DO  j = 1, 10
  CALL rnarry(x,kkk)
END DO

RETURN
END SUBROUTINE rnstrt

END MODULE Knuth_random

PROGRAM main
!      a rudimentary test program:
USE Knuth_random
IMPLICIT NONE

INTEGER  :: a(2009), i
REAL     :: u(1000), aver, dev, sumsq, stdev

CALL rnstrt(310952)
DO  i=1,2010
  CALL rnarry(a, 1009)
END DO
WRITE(*, '(I15)') a(1)
!                   the number should be 211101277
CALL rnstrt(310952)
DO  i=1,1010
  CALL rnarry(a, 2009)
END DO
WRITE(*, '(I15)') a(1)
!                                 again, 211101277

! Generate real variables.

CALL rand(u, 1000)
aver = 0.0
sumsq = 0.0
DO i = 1, 1000
  dev = u(i) - aver
  aver = aver + dev/i
  sumsq = sumsq + dev*(u(i) - aver)
END DO

! N.B. Dividing the sum of squares by (n-1) gives an unbiassed estimate
! of the variance; dividing by (n-1.5) gives an almost unbiassed estimate
! of the standard deviation.
stdev = SQRT(sumsq/998.5)

WRITE(*, '(a, f9.4, a, f9.4)') ' Mean = ', aver, '  Std. devn. = ', stdev
WRITE(*, '(a, f6.1, "  ", f9.4)')  &
         ' Values above should be close to ', 0.5, SQRT(1./12.)
STOP
END PROGRAM main


subroutine constraints_position(nTurbines, nBoundaries, turbineX, turbineY, boundaryVertices, &
                                &boundaryNormals, separation_squared, boundaryDistances)

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)
    ! in
    integer, intent(in) :: nTurbines, nBoundaries
    real(dp), dimension(nTurbines), intent(in) :: turbineX, turbineY
    real(dp), dimension(nBoundaries,2), intent(in) :: boundaryVertices, boundaryNormals
    !out
    real(dp), dimension(nTurbines,nBoundaries), intent(out) :: boundaryDistances
    real(dp), dimension((nTurbines-1)*nTurbines/2), intent(out) :: separation_squared

    call turbine_spacing_squared(nTurbines, turbineX, turbineY, separation_squared)
    call boundary_distances(nTurbines, nBoundaries, turbineX, turbineY, boundaryVertices, &
                            &boundaryNormals, boundaryDistances)
    end subroutine constraints_position

subroutine turbine_spacing_squared(nTurbines, turbineX, turbineY, separation_squared)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)
    ! in
    integer, intent(in) :: nTurbines
    real(dp), dimension(nTurbines), intent(in) :: turbineX, turbineY
    ! out
    real(dp), dimension((nTurbines-1)*nTurbines/2), intent(out) :: separation_squared
    ! local
    integer :: i, j, k
    k = 1
    do i = 1, nTurbines
        do j = i+1, nTurbines
            separation_squared(k)= (turbineX(j)-turbineX(i))**2+(turbineY(j)-turbineY(i))**2
            k = k+1
        end do
    end do

end subroutine turbine_spacing_squared

subroutine boundary_distances(nTurbines, nBoundaries, turbineX, turbineY, boundaryVertices, boundaryNormals, boundaryDistances)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)
    ! in
    integer, intent(in) :: nTurbines, nBoundaries
    real(dp), dimension(nTurbines), intent(in) :: turbineX, turbineY
    real(dp), dimension(nBoundaries,2), intent(in) :: boundaryVertices, boundaryNormals
    !out
    real(dp), dimension(nTurbines,nBoundaries), intent(out) :: boundaryDistances
    !local
    REAL(dp), PARAMETER :: pi=3.141592653589793_dp
    integer :: i, j
    real(dp) :: R
    real(dp), dimension(2) :: pa, d_vec

    if (nBoundaries .eq. 1) then
        do i = 1, nTurbines
            R = sqrt((turbineX(i)-boundaryNormals(1,1))**2+(turbineY(i)-boundaryNormals(1,2))**2)
            boundaryDistances(i,1) = boundaryVertices(1,1)-R
        end do
    else
        do i = 1, nTurbines
            do j = 1, nBoundaries
              pa(1) = boundaryVertices(j, 1)-turbineX(i)
              pa(2) = boundaryVertices(j, 2)-turbineY(i)
              ! d_vec = dot_product(pa,boundaryNormals(j))*boundaryNormals(j)
              d_vec(1) = (pa(1)*boundaryNormals(j, 1)+pa(2)*boundaryNormals(j, 2))*boundaryNormals(j, 1)
              d_vec(2) = (pa(1)*boundaryNormals(j, 1)+pa(2)*boundaryNormals(j, 2))*boundaryNormals(j, 2)
              ! boundaryDistances(i, j) = dot_product(d_vec, boundaryNormals(j))
              boundaryDistances(i, j) = d_vec(1)*boundaryNormals(j, 1)+d_vec(2)*boundaryNormals(j, 2)
            end do
        end do
    end if

end subroutine boundary_distances

!        Generated by TAPENADE     (INRIA, Ecuador team)
!  Tapenade 3.14 (r7259) - 18 Jan 2019 09:31
!
!  Differentiation of turbine_spacing_squared in forward (tangent) mode (with options multiDirectional i4 dr8 r4):
!   variations   of useful results: separation_squared
!   with respect to varying inputs: turbinex turbiney
SUBROUTINE TURBINE_SPACING_SQUARED_DV(nturbines, turbinex, turbinexd, &
& turbiney, turbineyd, separation_squared, separation_squaredd, nbdirs)

!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
  INTRINSIC KIND
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  INTEGER, INTENT(IN) :: nturbines
  REAL(dp), DIMENSION(nturbines), INTENT(IN) :: turbinex, turbiney
  REAL(dp), DIMENSION(nbdirs, nturbines), INTENT(IN) :: turbinexd, &
& turbineyd
! out
  REAL(dp), DIMENSION((nturbines-1)*nturbines/2), INTENT(OUT) :: &
& separation_squared
  REAL(dp), DIMENSION(nbdirs, (nturbines-1)*nturbines/2), INTENT(OUT)&
& :: separation_squaredd
! local
  INTEGER :: i, j, k
  INTEGER :: nd
  INTEGER :: nbdirs
  k = 1
  separation_squaredd(:, :) = 0.0_8
  DO i=1,nturbines
    DO j=i+1,nturbines
      DO nd=1,nbdirs
        separation_squaredd(nd, k) = 2*(turbinex(j)-turbinex(i))*(&
&         turbinexd(nd, j)-turbinexd(nd, i)) + 2*(turbiney(j)-turbiney(i&
&         ))*(turbineyd(nd, j)-turbineyd(nd, i))
      END DO
      separation_squared(k) = (turbinex(j)-turbinex(i))**2 + (turbiney(j&
&       )-turbiney(i))**2
      k = k + 1
    END DO
  END DO
END SUBROUTINE TURBINE_SPACING_SQUARED_DV

!  Differentiation of boundary_distances in forward (tangent) mode (with options multiDirectional i4 dr8 r4):
!   variations   of useful results: boundarydistances
!   with respect to varying inputs: turbinex turbiney
SUBROUTINE BOUNDARY_DISTANCES_DV(nturbines, nboundaries, turbinex, &
& turbinexd, turbiney, turbineyd, boundaryvertices, boundarynormals, &
& boundarydistances, boundarydistancesd, nbdirs)

!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
  INTRINSIC KIND
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  INTEGER, INTENT(IN) :: nturbines, nboundaries
  REAL(dp), DIMENSION(nturbines), INTENT(IN) :: turbinex, turbiney
  REAL(dp), DIMENSION(nbdirs, nturbines), INTENT(IN) :: turbinexd, &
& turbineyd
  REAL(dp), DIMENSION(nboundaries, 2), INTENT(IN) :: boundaryvertices, &
& boundarynormals
!out
  REAL(dp), DIMENSION(nturbines, nboundaries), INTENT(OUT) :: &
& boundarydistances
  REAL(dp), DIMENSION(nbdirs, nturbines, nboundaries), INTENT(OUT) ::&
& boundarydistancesd
!local
  REAL(dp), PARAMETER :: pi=3.141592653589793_dp
  INTEGER :: i, j
  REAL(dp) :: r
  REAL(dp), DIMENSION(nbdirs) :: rd
  REAL(dp), DIMENSION(2) :: pa, d_vec
  REAL(dp), DIMENSION(nbdirs, 2) :: pad, d_vecd
  INTRINSIC SQRT
  REAL(dp) :: arg1
  REAL(dp), DIMENSION(nbdirs) :: arg1d
  INTEGER :: nd
  INTEGER :: nbdirs
  IF (nboundaries .EQ. 1) THEN
    boundarydistancesd(:, :, :) = 0.0_8
    DO i=1,nturbines
      arg1 = (turbinex(i)-boundarynormals(1, 1))**2 + (turbiney(i)-&
&       boundarynormals(1, 2))**2
      DO nd=1,nbdirs
        arg1d(nd) = 2*(turbinex(i)-boundarynormals(1, 1))*turbinexd(nd, &
&         i) + 2*(turbiney(i)-boundarynormals(1, 2))*turbineyd(nd, i)
        IF (arg1 .EQ. 0.0) THEN
          rd(nd) = 0.0_8
        ELSE
          rd(nd) = arg1d(nd)/(2.0*SQRT(arg1))
        END IF
        boundarydistancesd(nd, i, 1) = -rd(nd)
      END DO
      r = SQRT(arg1)
      boundarydistances(i, 1) = boundaryvertices(1, 1) - r
    END DO
  ELSE
    boundarydistancesd(:, :, :) = 0.0_8
    pad(:, :) = 0.0_8
    d_vecd(:, :) = 0.0_8
    DO i=1,nturbines
      DO j=1,nboundaries
        DO nd=1,nbdirs
          pad(nd, 1) = -turbinexd(nd, i)
          pad(nd, 2) = -turbineyd(nd, i)
! d_vec = dot_product(pa,boundaryNormals(j))*boundaryNormals(j)
          d_vecd(nd, 1) = boundarynormals(j, 1)*(boundarynormals(j, 1)*&
&           pad(nd, 1)+boundarynormals(j, 2)*pad(nd, 2))
          d_vecd(nd, 2) = boundarynormals(j, 2)*(boundarynormals(j, 1)*&
&           pad(nd, 1)+boundarynormals(j, 2)*pad(nd, 2))
! boundaryDistances(i, j) = dot_product(d_vec, boundaryNormals(j))
          boundarydistancesd(nd, i, j) = boundarynormals(j, 1)*d_vecd(nd&
&           , 1) + boundarynormals(j, 2)*d_vecd(nd, 2)
        END DO
        pa(1) = boundaryvertices(j, 1) - turbinex(i)
        pa(2) = boundaryvertices(j, 2) - turbiney(i)
        d_vec(1) = (pa(1)*boundarynormals(j, 1)+pa(2)*boundarynormals(j&
&         , 2))*boundarynormals(j, 1)
        d_vec(2) = (pa(1)*boundarynormals(j, 1)+pa(2)*boundarynormals(j&
&         , 2))*boundarynormals(j, 2)
        boundarydistances(i, j) = d_vec(1)*boundarynormals(j, 1) + d_vec&
&         (2)*boundarynormals(j, 2)
      END DO
    END DO
  END IF
END SUBROUTINE BOUNDARY_DISTANCES_DV

!  Differentiation of constraints_position in forward (tangent) mode (with options multiDirectional i4 dr8 r4):
!   variations   of useful results: separation_squared boundarydistances
!   with respect to varying inputs: turbinex turbiney
!   RW status of diff variables: turbinex:in turbiney:in separation_squared:out
!                boundarydistances:out
SUBROUTINE CONSTRAINTS_POSITION_DV(nturbines, nboundaries, turbinex, &
& turbinexd, turbiney, turbineyd, boundaryvertices, boundarynormals, &
& separation_squared, separation_squaredd, boundarydistances, &
& boundarydistancesd, nbdirs)

!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
  INTRINSIC KIND
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  INTEGER, INTENT(IN) :: nturbines, nboundaries
  REAL(dp), DIMENSION(nturbines), INTENT(IN) :: turbinex, turbiney
  REAL(dp), DIMENSION(nbdirs, nturbines), INTENT(IN) :: turbinexd, &
& turbineyd
  REAL(dp), DIMENSION(nboundaries, 2), INTENT(IN) :: boundaryvertices, &
& boundarynormals
!out
  REAL(dp), DIMENSION(nturbines, nboundaries), INTENT(OUT) :: &
& boundarydistances
  REAL(dp), DIMENSION(nbdirs, nturbines, nboundaries), INTENT(OUT) ::&
& boundarydistancesd
  REAL(dp), DIMENSION((nturbines-1)*nturbines/2), INTENT(OUT) :: &
& separation_squared
  REAL(dp), DIMENSION(nbdirs, (nturbines-1)*nturbines/2), INTENT(OUT)&
& :: separation_squaredd
  INTEGER :: nbdirs
  CALL TURBINE_SPACING_SQUARED_DV(nturbines, turbinex, turbinexd, &
&                           turbiney, turbineyd, separation_squared, &
&                           separation_squaredd, nbdirs)
  CALL BOUNDARY_DISTANCES_DV(nturbines, nboundaries, turbinex, turbinexd&
&                      , turbiney, turbineyd, boundaryvertices, &
&                      boundarynormals, boundarydistances, &
&                      boundarydistancesd, nbdirs)
END SUBROUTINE CONSTRAINTS_POSITION_DV


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MFOpemMPExample2

    use omp_lib

    implicit none
    private

    type,  public :: TFExample2
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present()
        integer(selected_int_kind(18)), parameter :: intervals = 1e7
        integer(selected_int_kind(18)) :: i
        integer :: nthreads, threadid

        real(kind(1.d0)), parameter :: PI25DT = acos(-1.d0)
        real(kind(1.d0)) :: dx, sum, x
        real(kind(1.d0)) :: f, pi

        real(kind(1.d0)) :: time1, time2

        !$omp parallel
        nthreads = OMP_GET_NUM_THREADS()
        threadid = OMP_GET_THREAD_NUM()
        if (threadid == 0) then
            print '(A,I)', 'The number of threads: ', nthreads
        end if
        !$omp end parallel

        print '(A, I)', 'The number of intervals: ', intervals
        sum   = 0.d0
        dx    = 1.d0 / intervals
        time1 = omp_get_wtime()

        !$omp parallel do private(x, f) &
        !$omp reduction(+:sum)
        do i = intervals, 1, -1
            x = dx * (i - 0.5d0)
            f = 4.d0 / (1.d0 + x * x)
            sum = sum + f
        end do
        !$omp end parallel do

        pi    = dx * sum
        time2 = omp_get_wtime()

        print '(a13,2x,f30.25)', 'Computed PI = ', pi
        print '(a13,2x,f30.25)', 'The true PI = ', PI25DT
        print '(a13,2x,f30.25)', 'Error         ', PI25DT - pi
        print '(X)'
        print *, 'Elapsed time ', time2 - time1, ' s.'
    end subroutine
end module


c  smooth a spectrum with a window of diameter = iwidth pixels
c  using inverse variance weighting
c  return the smoothed spectrum and new rms
c  the original spectrum is preserved.

c Weighted mean generally:
c   xmean = sum(w_i * x_i) / sum(w_i)
c   sigma(xmean) = sqrt(sum(w_i^2 * sigma_i^2)) / sum(w_i)
c here the weight is w_i = 1/sigma_i^2
c   so sigma(xmean) = (sum(1/sigma_i^2))^-0.5 = (sum(w_i))^-0.5

c Note that the resulting pixels are correlated, so this might
c not be ideal.  I had some problems in the linrebinerr and logrebinerr
c routines.  One can also rebin the variance just like the flux
c (as if Poisson noise), and if IFVARCORR=0 this happens.
c  then var(xmean) = sum(w_i * var_i) / sum(w_i)

      subroutine weightsmooth(n,spin,rmsin,iwidth,spout,rmsout)

      parameter(IFVARCORR=0)

      real spin(n),spout(n)
      real rmsin(n),rmsout(n)
      integer iwidth
c      real temparr(n)
c      external select

      include 'pcredshift.h'

c high cut on input rms, i.e. anything with very
c large rms is ignored to avoid underflows, very low
c rms is assumed to be specious
      rmscuthi = 1.e10
      rmscutlo = 1.e-3

c  if smoothing is 1 or 0 pixels, array is unchanged
      if (iwidth .le. 1) then
         do i=1,n
            spout(i) = spin(i)
            rmsout(i) = rmsin(i)
         end do
         return
      end if

c compute radii for smoothing window
c if iwidth is odd we get a symmetric window, if it's even,
c truncate low side down, to
c make the high side the long side (no particular reason)
      irlow = int((iwidth-1)/2)
      irhigh = iwidth-irlow-1

      do i=1,n
         i1=max(1,i-irlow)
         i2=min(n,i+irhigh)
         np=0
         do j=i1,i2
            sum = 0.0
            varsum = 0.0
            wtsum = 0.0
            if(spin(j) .gt. bad .and. rmsin(j) .gt. rmscutlo
     $           .and. rmsin(j) .lt. rmscuthi) then
               np = np+1
               var = rmsin(j)**2
               weight = 1. / var
               sum = sum + spin(j)*weight
               wtsum = wtsum + weight
               if (IFVARCORR .eq. 0) then
                  varsum = varsum + var*weight
c               else
c                  varsum = varsum + var* weight**2
               end if
            end if
         end do
         if (np .eq. 0) then
            spout(i) = badset
            rmsout(i) = rmsin(i)
         else
            spout(i) = sum / wtsum
            if (IFVARCORR .eq. 0) then
               rmsout(i) = sqrt(varsum / wtsum)
            else
c               rmsout(i) = sqrt(varsum) / wtsum
               rmsout(i) = 1. / sqrt(wtsum)
            end if
         end if
      end do

      return
      end


      SUBROUTINE ratlsq(fn,a,b,mm,kk,cof,dev)
      INTEGER kk,mm,NPFAC,MAXC,MAXP,MAXIT
      DOUBLE PRECISION a,b,dev,cof(mm+kk+1),fn,PIO2,BIG
      PARAMETER (NPFAC=8,MAXC=20,MAXP=NPFAC*MAXC+1,MAXIT=5,
     *PIO2=3.141592653589793D0/2.D0,BIG=1.D30)
      EXTERNAL fn
CU    USES fn,ratval,dsvbksb,dsvdcmp
      INTEGER i,it,j,ncof,npt
      DOUBLE PRECISION devmax,e,hth,pow,sum,bb(MAXP),coff(MAXC),
     *ee(MAXP),fs(MAXP),u(MAXP,MAXC),v(MAXC,MAXC),w(MAXC),wt(MAXP),
     *xs(MAXP),ratval
      ncof=mm+kk+1
      npt=NPFAC*ncof
      dev=BIG
      do 11 i=1,npt
        if (i.lt.npt/2) then
          hth=PIO2*(i-1)/(npt-1.d0)
          xs(i)=a+(b-a)*sin(hth)**2
        else
          hth=PIO2*(npt-i)/(npt-1.d0)
          xs(i)=b-(b-a)*sin(hth)**2
        endif
        fs(i)=fn(xs(i))
        wt(i)=1.d0
        ee(i)=1.d0
11    continue
      e=0.d0
      do 17 it=1,MAXIT
        do 14 i=1,npt
          pow=wt(i)
          bb(i)=pow*(fs(i)+sign(e,ee(i)))
          do 12 j=1,mm+1
            u(i,j)=pow
            pow=pow*xs(i)
12        continue
          pow=-bb(i)
          do 13 j=mm+2,ncof
            pow=pow*xs(i)
            u(i,j)=pow
13        continue
14      continue
        call dsvdcmp(u,npt,ncof,MAXP,MAXC,w,v)
        call dsvbksb(u,w,v,npt,ncof,MAXP,MAXC,bb,coff)
        devmax=0.d0
        sum=0.d0
        do 15 j=1,npt
          ee(j)=ratval(xs(j),coff,mm,kk)-fs(j)
          wt(j)=abs(ee(j))
          sum=sum+wt(j)
          if(wt(j).gt.devmax)devmax=wt(j)
15      continue
        e=sum/npt
        if (devmax.le.dev) then
          do 16 j=1,ncof
            cof(j)=coff(j)
16        continue
          dev=devmax
        endif
        write (*,10) it,devmax
17    continue
      return
10    FORMAT (1x,'ratlsq iteration=',i2,' max error=',1pe10.3)
      END

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


      PROGRAM LA_SGEES_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GEES
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N, SDIM
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), WR(:), WI(:), VS(:,:)
!  .. "Intrinsic Functions" ..
      INTERFACE
         LOGICAL FUNCTION SELECT( X, Y )
           USE LA_PRECISION, ONLY: WP => SP
           REAL(WP), INTENT(IN) :: X, Y
         END FUNCTION SELECT
      END INTERFACE
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GEES Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), VS(N,N), WR(N), WI(N) )

      OPEN(UNIT=21,FILE='gees.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=A

      WRITE(*,*)'Matrix A:'
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(A(I,:));
      ENDDO

      WRITE(*,*) 'CALL LA_GEES( A, WR, WI )'
      CALL LA_GEES( A, WR, WI )

      WRITE(*,*)'Matrix A on exit :'
      DO I=1,N;
         WRITE(*,"(5(F12.5,1X))") A(I,:);
      ENDDO

      WRITE(*,*) 'WR on exit :'
      DO I=1,N;
         WRITE(*,"(5(F12.5,1X))") WR(I)
      ENDDO

      WRITE(*,*) 'WI on exit :'
      DO I=1,N;
      WRITE(*,"(5(F12.5,1X))") WI(I)
      ENDDO

      WRITE(*,*)
      WRITE(*,*)' * EXAMPLE 2 * '

      WRITE(*,*) "CALL LA_GEES( A, WR, WI, VS, SELECT, SDIM, INFO )"
      CALL LA_GEES( AA, WR, WI, VS, SELECT, SDIM, INFO )

      WRITE(*,*)'Matrix A on exit :'
      DO I=1,N;
         WRITE(*,"(5(F12.5,1X))") AA(I,:);
      ENDDO

      WRITE(*,*) 'WR on exit :'
      DO I=1,N;
         WRITE(*,"(5(F12.5,1X))") WR(I)
      ENDDO

      WRITE(*,*) 'WI on exit :'
      DO I=1,N;
      WRITE(*,"(5(F12.5,1X))") WI(I)
      ENDDO

      WRITE(*,*) 'VS on exit :'
      DO I=1,N;
         WRITE(*,"(5(F12.7,1X))") VS(I,:);
      ENDDO

      WRITE(*,*) ' SDIM = ', SDIM
      WRITE(*,*) ' INFO = ', INFO

    END PROGRAM LA_SGEES_EXAMPLE

! CONTAINS
    LOGICAL FUNCTION SELECT(X, Y )
    USE LA_PRECISION, ONLY: WP => SP
    INTRINSIC  EPSILON
      REAL(WP), INTENT(IN) :: X,Y
!      IF (ABS(Y) <= 1.1921E-7) THEN
       IF (ABS(Y) <= EPSILON(1.0_WP)) THEN
          SELECT = .TRUE.
      ELSE
         SELECT = .FALSE.
      ENDIF

    END FUNCTION SELECT


subroutine Capac (Unscaled_RAF,H,B1_P,B2_P,vfl2, sgma)
  use simsphere_mod
  implicit none

!       INCLUDE 'modvars.h'

  real :: IXCAP
  integer :: NCAP, IDEL, JDEL, CAPRAT, ITRAP=0
  real :: capini, ZADD, FPM, ZUH, Unscaled_RAF, B1_P, B2_P, vfl2 , H
  real :: VOLISO, RSTDIV, ADDIT, AROOT, BROOT, CROOT, ACTSQRT
  real :: PES, VOLRMO, SGMA

  ZADD = ZG + ZP * FRZP
  FPM = 1 - FRHGT
  ZUH = ZP * (1-FRZP)

! **  below there are two solutions for psist. The first is the
! **  log, while the second is a regular integral based on volume
! **  to a power.  There are also two similar solutions for zst
! **  and capacitance.
! **  Note also that psist, psist and psix are a time step behind because
! **  psist is not allowed to exceed psix of the previous time
! **  step (psix is a function of psis).
! **  There are also to ways to set the volume of water in
! **  storage. If xcap is set equal to zero, then volist storage is a
! **  function of psig. If not, it is a function of xcap or
! **  relative water content

   IF (JCAP == 1) THEN

     NCAP = RCCAP
     IDEL = 0
     JDEL = 0
     PSIX = PSIG - FRHGT * H
     IXCAP = VOLREL
     VOLREL = .01 * VOLREL
     CAPINI = VOLINI / RKOCAP
     JCAP = 2

     IF (eq(IXCAP,0.0)) THEN

        IF (NCAP == 1) THEN
          VOLIST = VOLINI * EXP ( CAPINI * (PSIG - FRHGT * H)            &
                   / VOLINI )

          CAPACI = CAPINI * ( VOLIST ) / VOLINI

        else IF (NCAP /= 1) THEN

          CAPRAT =  (RCCAP - 1)/ RCCAP
          VOLIST = VOLINI * ( 1 + CAPINI * (PSIG - FRHGT * H)            &
                   * CAPRAT / VOLINI ) ** ( 1 / CAPRAT )

          CAPACI = CAPINI * ( ( VOLIST ) / VOLINI ) **                   &
                   ( 1 / RCCAP )

        end if

! ** It is possible that the volist will be calculated as being
! ** less than zero.  This is impossible.  Therefore, we set:

      IF (VOLIST < 0) THEN

        VOLIST = .00001*VOLINI
        VOLRMV = .99999*VOLINI

      end if

    else

      VOLIST = VOLREL * VOLINI
      VOLISO = VOLIST

      IF (NCAP == 1) THEN

        CAPACI = CAPINI * VOLREL

      else IF (NCAP /= 1) THEN

        CAPRAT =  (RCCAP - 1)/ RCCAP
        CAPACI = CAPINI * ( VOLREL ) ** ( 1 / RCCAP )

      end if

    end if

  end if

  VOLREL = VOLIST / VOLINI

  IF (NCAP == 1) THEN

     PSIST = ( VOLINI / CAPINI ) * LOG ( VOLREL )
     CAPACI = CAPINI * ( VOLIST ) / VOLINI

  ELSE

     PSIST = (VOLINI/CAPINI) * ( VOLREL ** CAPRAT - 1 ) * (RCCAP /( RCCAP - 1 ) )

 ! **  THIS IF STATEMENT IS IN PLACE OF VOLUME CONSTRAINTS

     IF (PSIST >= 0) THEN
       PSIST = 0
     END IF

 ! **  The following if statement causes psist to fall as volume
 ! **  approaches zero (the above equation reaches a limit).
 ! **  (ITRAP is defined below to prevent the loop from being
 ! **   exercised on the first time step.)
 ! **   The next statement prevents psist from becoming more
 ! positive then psig

     IF (ITRAP == 1 .and. eq(DELTVST,0.0)) THEN
       PSIST = PSIX
     END IF

     CAPACI = CAPINI * ( VOLREL ) ** ( 1 / RCCAP)

   END IF

  IF (NCAP == 1) THEN
    ZST = ZSTINI / VOLREL
  ELSE IF (NCAP /= 1) THEN
    ZST = ZSTINI * ( 1./VOLREL ) ** ( RZCAP )
  END IF

! **  The following if statement prevents zst from becoming very
!**   large.
  IF (ZST > 1E3) THEN
    ZST = 1E3
  END IF

! **  The following if statements prevent psist from exceeding
! **  psix during a time interval

  IF (DELTVST < 0 .and. PSIST < PSIX) THEN
    PSIST = PSIX
  ELSE IF (DELTVST > 0 .and. PSIST > PSIX) THEN
    PSIST = PSIX
  END IF

  RSTDIV = Unscaled_RAF + ( RCUT * RSCRIT ) / ( RCUT + RSCRIT )

! **  we need to compare psig to psigc before proceeding
! **  we can determine this by solving for psig given various
! **  parameters.

! **   ADDIT  is an additional term that incorporates storage flux.

  ADDIT = 1 + ZUH / ZADD + ZUH / ZST

!**    define a critical water potential. As the flux
! **   from storage approaches zero, it approaches that of
! **   the soil.

  PSIWC =  SGMA * VFL * ZUH / RSTDIV + PSICE + beta * vfl2 + FPM * H
  PSISUP = PSIX

  IF (PSISUP > PSIWC) THEN
    AROOT = FS * FT * b1_p * (RCUT + Unscaled_RAF) * ( ZST * (-1) - ZADD )

    BROOT = FS * FT * (RCUT + Unscaled_RAF) * ( RMIN *                  &
            ( - ZST - ZADD ) + b1_p * ( ZST * ( PSIG - BETA *           &
            vfl2 - H ) + ZADD * (PSIST - beta * vfl2 - FPM * H )        &
            - ZADD * ZST * SGMA * VFL * ADDIT /                         &
            ( RCUT + Unscaled_RAF) ) ) + RCUT * Unscaled_RAF * ( - ZST - ZADD )

    CROOT = FS * FT * (RCUT + Unscaled_RAF) * ( RMIN * ( ZST            &
            * (PSIG - beta * vfl2 - H ) + ZADD * ( PSIST                &
            - beta * vfl2 - FPM * H )                                   &
            - ZADD * ZST * SGMA * VFL * ADDIT / (RCUT + Unscaled_RAF)   &
            ) )                                                         &
            + RCUT * Unscaled_RAF * ( ZST * (PSIG - beta * vfl2 - H )   &
            + ZADD * ( PSIST - beta * vfl2 - FPM * H ) )                &
            - RCUT * ZADD * ZST * SGMA * VFL * ADDIT

  ELSE

    AROOT = FS * FT * b2_p * ( RCUT + Unscaled_RAF ) * ( ZST + ZADD )

    BROOT = FS * FT *  ( RCUT + Unscaled_RAF ) * ( ( RMIN               &
            + b1_p * PSICE + b2_p * PSICE) * ( -ZST - ZADD )            &
            - b2_p * ( ZST * (PSIG - beta * vfl2 - H )                  &
            + ZADD * ( PSIST - beta * vfl2 - FPM * H )                  &
            - ZADD * ZST * SGMA * VFL * ADDIT /                         &
            (RCUT + Unscaled_RAF) ) )                                   &
            + RCUT * Unscaled_RAF * ( - ZST - ZADD )

    CROOT = FS * FT* (RCUT + Unscaled_RAF) * ( RMIN + b1_p * PSICE      &
            + b2_p * PSICE ) * ( ZST * (PSIG - beta * vfl2 - H )        &
            + ZADD * (PSIST - beta * vfl2 - FPM * H )                   &
            - ZADD * ZST * SGMA * VFL * ADDIT /(RCUT + Unscaled_RAF))   &
            + RCUT * Unscaled_RAF * ( ZST * ( PSIG - beta * vfl2 - H)   &
            + ZADD * (PSIST - beta * vfl2 - FPM * H ) )                 &
            - RCUT * ZADD * ZST * SGMA * VFL * ADDIT

  END IF

  ACTSQRT  = BROOT ** 2 - 4 * AROOT * CROOT
  PSIE = ( -BROOT - SQRT ( ACTSQRT ) ) / (2 * AROOT )
  RS = stomrs(ft,tf,rmin,mintemp,maxtemp,psisup,psiwc,b1,b2,psie,psice,fs)

! * * STRESS INDICES

  PSIM = PSIE + beta * vfl2
  PES = XLAI/2 + 1
  RLELF = SGMA * VFL / (RS*RCUT/(RS + RCUT) + Unscaled_RAF)
  PSIX = RLELF  * ZUH + PSIM + FPM * H
  FST = -( PSIST - PSIX ) / ZST
  DELTVST = -DELTA * ( PSIST - PSIX ) / (ZST * LE * RHOW )
  FLUXGD = ( PSIG - PSIX - FRHGT * H ) / ZADD
  VOLRMO = VOLRMV
  VOLIST = VOLIST + DELTVST
  VOLRMV = VOLINI - VOLIST

! **   the following if statements prevent the volume in
! **   storage from becoming negative.

  IF (VOLRMV < VOLINI .and. DELTVST <= 0) THEN
    IF (IDEL == 0) THEN
      DELTVST = (VOLINI - VOLRMO)
      IDEL = 1
    ELSE
      DELTVST = 0.0
      ITRAP = 1
    END IF
    VOLRMV = .99999*VOLINI
    VOLIST = .00001*VOLINI
  END IF

  return
end


module numerical

use phys_consts                     !for differentiating around a object embedded in flow

implicit none

contains

  function derivative2D1(f,dx1)
    real(8), dimension(:,:), intent(in) :: f    !ghost cells not present...
    real(8), dimension(:), intent(in) :: dx1    !presumed backward diffs.

    integer :: lx1,lx2,ix2
    real(8), dimension(1:size(f,1),1:size(f,2)) :: derivative2D1

    lx1=size(f,1)
    lx2=size(f,2)

    !$omp parallel do
    do ix2=1,lx2
      derivative2D1(1,ix2)=(f(2,ix2)-f(1,ix2))/dx1(2)
      derivative2D1(2:lx1-1,ix2)=(f(3:lx1,ix2)-f(1:lx1-2,ix2))/(dx1(3:lx1)+dx1(2:lx1-1))
      derivative2D1(lx1,ix2)=(f(lx1,ix2)-f(lx1-1,ix2))/dx1(lx1)
    end do
  end function derivative2D1

  function derivative2D2(f,dx2)
    real(8), dimension(:,:), intent(in) :: f    !ghost cells not present...
    real(8), dimension(:), intent(in) :: dx2    !presumed backward diffs.

    integer :: lx1,lx2,ix1
    real(8), dimension(1:size(f,1),1:size(f,2)) :: derivative2D2

    lx1=size(f,1)
    lx2=size(f,2)

    !$omp parallel do
    do ix1=1,lx1
      derivative2D2(ix1,1)=(f(ix1,2)-f(ix1,1))/dx2(2)
      derivative2D2(ix1,2:lx2-1)=(f(ix1,3:lx2)-f(ix1,1:lx2-2))/(dx2(3:lx2)+dx2(2:lx2-1))
      derivative2D2(ix1,lx2)=(f(ix1,lx2)-f(ix1,lx2-1))/dx2(lx2)
    end do
  end function derivative2D2

  function derivative2D2p(f,dx2)

    !Derivative on a periodic domain

    real(8), dimension(:,:), intent(in) :: f    !ghost cells not present...
    real(8), dimension(:), intent(in) :: dx2    !presumed backward diffs.

    integer :: lx1,lx2,ix1
    real(8), dimension(1:size(f,1),1:size(f,2)) :: derivative2D2p

    lx1=size(f,1)
    lx2=size(f,2)

    !$omp parallel do
    do ix1=1,lx1
      derivative2D2p(ix1,1)=(f(ix1,2)-f(ix1,lx2))/(dx2(2)+dx2(1))
      derivative2D2p(ix1,2:lx2-1)=(f(ix1,3:lx2)-f(ix1,1:lx2-2))/(dx2(3:lx2)+dx2(2:lx2-1))
      derivative2D2p(ix1,lx2)=(f(ix1,1)-f(ix1,lx2-1))/(dx2(1)+dx2(lx2))
    end do

  end function derivative2D2p

  function derivative2D1obj(f,dx1,x1,x2)

    !DIFFERENTIATE AROUND AN OBJECT,x1

    real(8), dimension(:,:), intent(in) :: f    !ghost cells not present...
    real(8), dimension(:), intent(in) :: dx1    !presumed backward diffs.
    real(8), dimension(-1:), intent(in) :: x1
    real(8), dimension(-1:), intent(in) :: x2

    integer :: lx1,lx2,ix1,ix2
    real(8) :: ffwd,fback,dxval
    real(8), dimension(1:size(f,1),1:size(f,2)) :: derivative2D1obj

    lx1=size(f,1)
    lx2=size(f,2)

    do ix2=1,lx2
      derivative2D1obj(1,ix2)=(f(2,ix2)-f(1,ix2))/dx1(2)
      do ix1=2,lx1-1
        if (inside_obj(x1(ix1),x2(ix2))) then          !location of interest is inside object, do nothing
          derivative2D1obj(ix1,ix2)=0d0
        else
          if (inside_obj(x1(ix1+1),x2(ix2))) then        !point is outside obj, but need to check foward location.  If inside, back diff.
            ffwd=f(ix1,ix2)
!            fback=f(ix1-1,ix2)
            fback=ffwd    !force zero
            dxval=dx1(ix1)
          elseif (inside_obj(x1(ix1-1),x2(ix2))) then    !is the backward point inside object?  Use fwd diff.
            ffwd=f(ix1+1,ix2)
!            fback=f(ix1,ix2)
            fback=ffwd
            dxval=dx1(ix1+1)
          else                                           !neither is inside, so differentiate 2nd order centered
            ffwd=f(ix1+1,ix2)
            fback=f(ix1-1,ix2)
            dxval=dx1(ix1+1)+dx1(ix1)
          end if

          derivative2D1obj(ix1,ix2)=(ffwd-fback)/dxval
        end if
      end do
      derivative2D1obj(lx1,ix2)=(f(lx1,ix2)-f(lx1-1,ix2))/dx1(lx1)
    end do

  end function derivative2D1obj

  function derivative2D2obj(f,dx2,x1,x2)

    !DIFFERENTIATE AROUND AN OBJECT,x2

    real(8), dimension(:,:), intent(in) :: f    !ghost cells not present...
    real(8), dimension(:), intent(in) :: dx2    !presumed backward diffs.
    real(8), dimension(-1:), intent(in) :: x1
    real(8), dimension(-1:), intent(in) :: x2

    integer :: lx1,lx2,ix1,ix2
    real(8) :: ffwd,fback,dxval
    real(8), dimension(1:size(f,1),1:size(f,2)) :: derivative2D2obj

    lx1=size(f,1)
    lx2=size(f,2)

    do ix1=1,lx1
      derivative2D2obj(1,ix2)=(f(ix1,2)-f(ix1,1))/dx2(2)
      do ix2=2,lx2-1
        if (inside_obj(x1(ix1),x2(ix2))) then            !location of interest is inside object, do nothing
          derivative2D2obj(ix1,ix2)=0d0
        else
          if (inside_obj(x1(ix1),x2(ix2+1))) then        !point is outside obj, but need to check foward location.  If inside, back diff.
            ffwd=f(ix1,ix2)
!            fback=f(ix1,ix2-1)
            fback=ffwd
            dxval=dx2(ix2)
          elseif (inside_obj(x1(ix1),x2(ix2-1))) then    !is the backward point inside object?  Use fwd diff.
            ffwd=f(ix1,ix2+1)
!            fback=f(ix1,ix2)
            fback=ffwd
            dxval=dx2(ix2+1)
          else                                           !neither is inside, so differentiate 2nd order centered
            ffwd=f(ix1,ix2+1)
            fback=f(ix1,ix2-1)
            dxval=dx2(ix2+1)+dx2(ix2)
          end if

          derivative2D2obj(ix1,ix2)=(ffwd-fback)/dxval
        end if
      end do
      derivative2D2obj(ix1,lx2)=(f(ix1,lx2)-f(ix1,lx2-1))/dx2(lx2)
    end do

  end function derivative2D2obj

  function integral2D2(f,dx2)

    !------------------------------------------------------------
    !-------COMPUTE AN INTEGRAL ALONG THE 2-DIM.  IT IS EXPECTED THAT
    !-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
    !-------THEY ARE PASSED INTO THIS ROUTINE
    !------------------------------------------------------------

    real(8), dimension(:,:), intent(in) :: f
    real(8), dimension(1:size(f,2)), intent(in) :: dx2  !presumed backward diffs. (1:lx2)

    integer :: ix2,lx2
    real(8), dimension(1:size(f,1),1:size(f,2)) :: integral2D2

    lx2=size(f,2)

    integral2D2(:,1)=0d0
    do ix2=2,lx2
      integral2D2(:,ix2)=integral2D2(:,ix2-1)+0.5d0*(f(:,ix2)+f(:,ix2-1))*dx2(ix2)
    end do

  end function integral2D2

  function advec2D_MC(f,v1i,v2i,dt,dx1,dx1i,dx2,dx2i)
    real(8), dimension(-1:,-1:), intent(in) :: f    !f includes ghost cells
    real(8), dimension(:,:), intent(in) :: v1i
    real(8), dimension(0:), intent(in) :: dx1       !ith backward difference
    real(8), dimension(:), intent(in) :: dx1i
    real(8), dimension(:,:), intent(in) :: v2i
    real(8), dimension(0:), intent(in) :: dx2
    real(8), dimension(:), intent(in) :: dx2i
    real(8), intent(in) :: dt

    integer :: ix1,ix2,lx1,lx2
    real(8), dimension(-1:size(f,1)-2) :: fx1slice
    real(8), dimension(1:size(f,1)-3) :: v1slice
    real(8), dimension(-1:size(f,2)-2) :: fx2slice
    real(8), dimension(1:size(f,2)-3) :: v2slice
    real(8), dimension(-1:size(f,1)-2,-1:size(f,2)-2) :: advec2D_MC

    lx1=size(f,1)-4
    lx2=size(f,2)-4

    !x2-sweep (it appears that fortran doesn't differentiate b/t row and column arrays, so no reshapes...)
    !omp parallel do private(fx2slice,v2slice)
    do ix1=1,lx1
      fx2slice=f(ix1,:)
      v2slice=v2i(ix1,:)
      fx2slice=advec1D_MC(fx2slice,v2slice,dt,dx2,dx2i)
      advec2D_MC(ix1,:)=fx2slice
    end do

    !copy x2 boundary conditions to partially updated variable for next sweep
    !advec2D_MC(:,-1:0)=f(:,-1:0);
    !advec2D_MC(:,lx2+1:lx2+2)=f(:,lx2+1:lx2+2);
    advec2D_MC(-1:0,:)=f(-1:0,:);
    advec2D_MC(lx1+1:lx1+2,:)=f(lx1+1:lx1+2,:);

    !x1-sweep
    !$omp parallel do private(fx1slice,v1slice)
    do ix2=1,lx2
      fx1slice=advec2D_MC(:,ix2);
      v1slice=v1i(:,ix2);
      fx1slice=advec1D_MC(fx1slice,v1slice,dt,dx1,dx1i)
      advec2D_MC(:,ix2)=fx1slice;
    end do

  end function advec2D_MC

  function advec1D_MC(f,v1i,dt,dx1,dx1i)
    real(8), dimension(-1:), intent(in) :: f    !f includes ghost cells
    real(8), dimension(:), intent(in) :: v1i
    real(8), dimension(0:), intent(in) :: dx1   !ith backward difference
    real(8), dimension(:), intent(in) :: dx1i
    real(8), intent(in) :: dt

    integer :: ix1,lx1
    real(8), dimension(size(v1i)) :: phi
    real(8), dimension(0:size(v1i)) :: slope         !slopes only need through first layer of ghosts
    real(8) :: lslope,rslope,cslope
    real(8), dimension(-1:size(f)-2) :: advec1D_MC

    lx1=size(f)-4

    !Slopes
    lslope=(f(0)-f(-1))/dx1(0)
    do ix1=0,lx1+1
      rslope=(f(ix1+1)-f(ix1))/dx1(ix1+1)
      cslope=(f(ix1+1)-f(ix1-1))/(dx1(ix1)+dx1(ix1+1))
      slope(ix1)=minmod(cslope,minmod(2*lslope,2*rslope))

      lslope=rslope
    end do

    !Slope-limited flux at ***left*** wall of cell ix1.
    !The treatment of slope here (ie the dx1(ix1)) assumes that the grid point isp centered within the cell
    do ix1=1,lx1+1
      if (v1i(ix1) < 0) then
        phi(ix1)=f(ix1)*v1i(ix1) - 0.5*v1i(ix1)*(dx1(ix1)+v1i(ix1)*dt)*slope(ix1)
      else
        phi(ix1)=f(ix1-1)*v1i(ix1) + 0.5*v1i(ix1)*(dx1(ix1)-v1i(ix1)*dt)*slope(ix1-1)
      end if
    end do

    !flux differencing form
    advec1D_MC(1:lx1)=f(1:lx1)-dt*(phi(2:lx1+1)-phi(1:lx1))/dx1i

    !default to copying ghost cells
    advec1D_MC(-1:0)=f(-1:0)
    advec1D_MC(lx1+1:lx1+2)=f(lx1+1:lx1+2)
  end function advec1D_MC

  function minmod(a,b)
    real(8), intent(in) :: a,b
    real(8) :: minmod

    if (a*b <= 0.) then
      minmod=0.
    else if (abs(a) < abs(b)) then
      minmod=a
    else
      minmod=b
    end if
  end function minmod

end module numerical


PROGRAM F012

    ! Copyright 2021 Melwyn Francis Carlo
    ! FILE REFERENCE: http://www.naturalnumbers.org/primes.html

    IMPLICIT NONE

    INTEGER :: PRIME_NUM
    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/003/PrimeNumbers_Upto_1000000"

    INTEGER :: N          = 1 ! Just a dummy value.
    INTEGER :: COUNT_VAL  = 0
    INTEGER :: DIVISORS_N = 1

    INTEGER :: I, INDEX_VAL, N_MAX, N_SUM

    INTEGER, DIMENSION(2, 0:500) :: DIVISORS_ARR

    DO WHILE (DIVISORS_N <= 500)

        N     = 1001 + (1000 * COUNT_VAL)
        N_MAX = N + 999

        DO WHILE (N <= N_MAX)

            DIVISORS_ARR = 0
            N_SUM        = N * (N + 1) / 2

            DO WHILE (N_SUM /= 1)

                OPEN (2, FILE = FILENAME, STATUS = 'OLD')

                DO
                    READ(2, *, END=10) PRIME_NUM

                    IF (MOD(N_SUM, PRIME_NUM) == 0) THEN

                        INDEX_VAL = -1

                        DO I = 1, DIVISORS_ARR(1, 0)
                            IF (DIVISORS_ARR(2, I) == PRIME_NUM) THEN
                                INDEX_VAL = I
                                EXIT
                            END IF
                        END DO

                        IF (INDEX_VAL == -1) THEN
                            DIVISORS_ARR(1, 0) = DIVISORS_ARR(1, 0) + 1

                            DIVISORS_ARR(1, DIVISORS_ARR(1, 0))                &
                                = DIVISORS_ARR(1, DIVISORS_ARR(1, 0)) + 1

                            DIVISORS_ARR(2, DIVISORS_ARR(1, 0)) = PRIME_NUM
                        ELSE
                            DIVISORS_ARR(1, INDEX_VAL)                         &
                                = DIVISORS_ARR(1, INDEX_VAL) + 1
                        END IF

                        N_SUM = N_SUM / PRIME_NUM
                        EXIT

                    END IF

                END DO

                10 CLOSE(2)

            END DO

            DIVISORS_N = 1
            DO I = 1, DIVISORS_ARR(1, 0)
                DIVISORS_N = DIVISORS_N * (DIVISORS_ARR(1, I) + 1)
            END DO

            N = N + 1

            IF (DIVISORS_N > 500) EXIT

        END DO

        COUNT_VAL = COUNT_VAL + 1

    END DO

    N = N - 1

    PRINT ('(I0)'), N * (N + 1) / 2

END PROGRAM F012


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine cholesky: Compute the brute-force stabilized
!        Cholesky decomposition of a square matrix.
!     Parameters:
!   SST - The matrix to determine the Cholesky decomposition of
!   n - The size of the matrix
!     Returns:
!   S - The computed Cholesky decomposition
!     ---> taken from RPMDrate
!
!     part of EVB
!
subroutine cholesky(SST, S, n)

    integer, intent(in)  :: n
    real*8, intent(in)   :: SST(n,n)
    real*8, intent(out)   :: S(n,n)
    real*8 :: D(n), L(n,n)

    integer i,j,k

    D = 0.d0
    L = 0.d0
    do i = 1,n
        L(i,i)=1.
        D(i)=SST(i,i)
        do j=1,i-1
            L(i,j)=SST(i,j);
            do k=1,j-1
                L(i,j)=L(i,j)-L(i,k)*L(j,k)*D(k)
            end do
            if (D(j).ne.0.) L(i,j)=L(i,j)/D(j)
        end do
        do k=1,i-1
            D(i)=D(i)-L(i,k)*L(i,k)*D(k)
        end do
    end do
    S=0.
    do i=1,n
        do j=1,i
            if (D(j)>0.) S(i,j)=S(i,j)+L(i,j)*sqrt(D(j))
        end do
    end do

end subroutine cholesky


subroutine SHExpandDHC(grid, n, cilm, lmax, norm, sampling, csphase, &
                       lmax_calc, exitstatus)
!------------------------------------------------------------------------------
!
!   This routine will expand a grid containing N samples in both longitude
!   and latitude (or N x 2N, see below) into spherical harmonics. This routine
!   makes use of the sampling theorem presented in Driscoll and Healy (1994)
!   and employs FFTs when calculating the exponential terms. The number of
!   samples, N, must be EVEN for this routine to work, and the spherical
!   harmonic expansion is exact if the function is bandlimited to degree N/2-1.
!   Legendre functions are computed on the fly using the scaling methodology
!   presented in Holmes and Featherston (2002). When NORM is 1, 2 or 4, these
!   are accurate to about degree 2800. When NORM is 3, the routine is only
!   stable to about degree 15! If the optional parameter LMAX_CALC is
!   specified, the spherical harmonic coefficients will only be calculated up
!   to this degree.
!
!   If SAMPLING is 1 (default), the input grid contains N samples in latitude
!   from 90 to -90+interval, and N samples in longitude from 0 to
!   360-2*interval, where interval is the latitudinal sampling interval 180/N.
!   Note that the datum at 90 degees North latitude is ultimately downweighted
!   to zero, so this point does not contribute to the spherical harmonic
!   coefficients. If SAMPLING is 2, the input grid must contain N samples in
!   latitude and 2N samples in longitude. In this case, the sampling intervals
!   in latitude and longitude are 180/N and 360/N respectively. When performing
!   the FFTs in longitude, the frequencies greater than N/2-1 are simply
!   discarded to prevent aliasing.
!
!   The complex spherical harmonics are output in the array cilm. Cilm(1,,)
!   contains the positive m term, wheras cilm(2,,) contains the negative m
!   term. The negative order Legendre functions are calculated making use of
!   the identity Y_{lm}^* = (-1)^m Y_{l,-m}.
!
!   Calling Parameters
!
!       IN
!           grid        Equally sampled grid in latitude and longitude of
!                       dimension (1:N, 1:N) or and equally spaced grid of
!                       dimension (1:N,2N).
!           N           Number of samples in latitude and longitude (for
!                       SAMPLING=1), or the number of samples in latitude (for
!                       SAMPLING=2).
!
!       OUT
!           cilm        Array of spherical harmonic coefficients with dimension
!                       (2, LMAX+1, LMAX+1), or, if LMAX_CALC is present
!                       (2, LMAX_CALC+1, LMAX_CALC+1).
!           lmax        Spherical harmonic bandwidth of the grid. This
!                       corresponds to the maximum spherical harmonic degree of
!                       the expansion if the optional parameter LMAX_CALC is
!                       not specified.
!
!       OPTIONAL (IN)
!           norm        Normalization to be used when calculating Legendre
!                       functions
!                           (1) "geodesy" (default)
!                           (2) Schmidt
!                           (3) unnormalized
!                           (4) orthonormalized
!           sampling    (1) Grid is N latitudes by N longitudes (default).
!                       (2) Grid is N by 2N. The higher frequencies resulting
!                       from this oversampling are discarded, and hence not
!                       aliased into lower frequencies.
!           csphase     1: Do not include the Condon-Shortley phase factor of
!                       (-1)^m (default). -1: Apply the Condon-Shortley phase
!                       factor of (-1)^m.
!           lmax_calc   The maximum spherical harmonic degree calculated in the
!                       spherical harmonic expansion.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!       1.  This routine does not use the fast legendre transforms that
!           are presented in Driscoll and Heally (1994).
!       2.  Use of a N by 2N grid is implemented because many geographic grids
!           are sampled this way. When taking the Fourier transforms in
!           longitude, all of the higher frequencies are ultimately discarded.
!           If, instead, every other column of the grid were discarded to form
!           a NxN grid, higher frequencies could be aliased into lower
!           frequencies.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use FFTW3
    use SHTOOLS, only: DHaj
    use ftypes
    use, intrinsic :: iso_c_binding

    implicit none

    complex(dp), intent(in) :: grid(:,:)
    complex(dp), intent(out) :: cilm(:,:,:)
    integer(int32), intent(in) :: n
    integer(int32), intent(out) :: lmax
    integer(int32), intent(in), optional :: norm, sampling, csphase, lmax_calc
    integer(int32), intent(out), optional :: exitstatus
    complex(dp) :: cc(2*n), ccs(2*n), gridl(2*n), gridls(2*n), fcoef1(2*n), &
                   fcoef2(2*n), ffc1(-1:1), ffc2(-1:1)
    integer(int32) :: l, m, i, l1, m1, i_eq, i_s, lnorm, astat(5), lmax_comp, &
                      nlong
    type(C_PTR) :: plan, plans
    real(dp) :: pi, aj(n), theta, prod, scalef, rescalem, u, p, pmm, pm1, &
                pm2, z
    real(dp), save, allocatable :: ff1(:,:), ff2(:,:), sqr(:)
    integer(int8), save, allocatable :: fsymsign(:,:)
    integer(int32), save :: lmax_old = 0, norm_old = 0
    integer(int32) :: phase

!$OMP   threadprivate(sqr, ff1, ff2, fsymsign, lmax_old, norm_old)

    if (present(exitstatus)) exitstatus = 0

    lmax = n / 2 - 1

    if (present(lmax_calc)) then
        if (lmax_calc > lmax) then
            print*, "Error --- SHExpandDHC"
            print*, "LMAX_CALC must be less than or equal to LMAX."
            print*, "LMAX = ", lmax
            print*, "LMAX_CALC = ", lmax_calc
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            lmax_comp = min(lmax, lmax_calc)

        end if

    else
        lmax_comp = lmax

    end if

    if (present(sampling)) then
        if (sampling /= 1 .and. sampling /= 2) then
            print*, "Error --- SHExpandDHC"
            print*, "Optional parameter SAMPLING must be 1 (N by N) " // &
                    "or 2 (N by 2N)."
            print*, "Input value is ", sampling
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

    end if

    if (mod(n,2) /= 0) then
        print*, "Error --- SHExpandDHC"
        print*, "The number of samples in latitude and longitude, " // &
                "n, must be even."
        print*, "Input value is ", n
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    else if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax_comp+1 .or. &
             size(cilm(1,1,:)) < lmax_comp+1) then
        print*, "Error --- SHExpandDHC"
        print*, "CILM must be dimensioned as (2, LMAX_COMP+1, LMAX_COMP+1)"
        print*, "where LMAX_COMP = MIN(N/2, LMAX_CALC+1)"
        print*, "N = ", n
        if (present(lmax_calc)) print*, "LMAX_CALC = ", lmax_calc
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (present(sampling)) then
        if (sampling == 1) then
            if (size(grid(:,1)) < n .or. size(grid(1,:)) < n) then
                print*, "Error --- SHExpandDHC"
                print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
                print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
                if (present(exitstatus)) then
                    exitstatus = 1
                    return
                else
                    stop
                end if

            end if

        else if (sampling == 2) then
            if (size(grid(:,1)) < n .or. size(grid(1,:)) < 2*n) then
                print*, "Error --- SHExpandDHC"
                print*, "GRIDDH must be dimensioned as (N, 2*N) where N is ", n
                print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
                if (present(exitstatus)) then
                    exitstatus = 1
                    return
                else
                    stop
                end if

            end if

        end if

    else
        if (size(grid(:,1)) < n .or. size(grid(1,:)) < n) then
            print*, "Error --- SHExpandDHC"
            print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
            print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(csphase)) then
        if (csphase /= -1 .and. csphase /= 1) then
            print*, "SHExpandDHC --- Error"
            print*, "CSPHASE must be 1 (exclude) or -1 (include)."
            print*, "Input value is ", csphase
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            phase = csphase

        end if

    else
        phase = 1

    end if

    if (present(norm)) then
        if (norm > 4 .or. norm < 1) then
            print*, "Error --- SHExpandDHC"
            print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), " // &
                    "3 (unnormalized), or 4 (orthonormalized)."
            print*, "Input value is ", norm
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

        lnorm = norm

    else
        lnorm = 1

    end if

    pi = acos(-1.0_dp)

    cilm = cmplx(0.0_dp, 0.0_dp, dp)

    scalef = 1.0e-280_dp

    if (present(exitstatus)) then
        call DHaj(n, aj, exitstatus=exitstatus)
        if (exitstatus /= 0) return
    else
        call DHaj(n, aj)
    end if

    aj(1:n) = aj(1:n) * sqrt(4.0_dp * pi)
    ! Driscoll and Heally use unity normalized spherical harmonics

    if (present(sampling)) then
        if (sampling == 1) then
            nlong = n

        else
            nlong = 2*n

        end if

    else
        nlong = n

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate recursion constants used in computing the Legendre functions.
    !
    !--------------------------------------------------------------------------
    if (lmax_comp /= lmax_old .or. lnorm /= norm_old) then
        if (allocated (sqr)) deallocate (sqr)
        if (allocated (ff1)) deallocate (ff1)
        if (allocated (ff2)) deallocate (ff2)
        if (allocated (fsymsign)) deallocate (fsymsign)

        allocate (sqr(2*lmax_comp+1), stat=astat(1))
        allocate (ff1(lmax_comp+1,lmax_comp+1), stat=astat(2))
        allocate (ff2(lmax_comp+1,lmax_comp+1), stat=astat(3))
        allocate (fsymsign(lmax_comp+1,lmax_comp+1), stat=astat(4))

        if (sum(astat(1:4)) /= 0) then
            print*, "Error --- SHExpandDHC"
            print*, "Problem allocating arrays SQR, FF1, FF2, or FSYMSIGN", &
                    astat(1), astat(2), astat(3), astat(4)
             if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if
        end if

        !----------------------------------------------------------------------
        !
        !   Calculate signs used for symmetry of Legendre functions about
        !   equator.
        !
        !----------------------------------------------------------------------
        do l = 0, lmax_comp, 1
            do m = 0, l, 1
                if (mod(l-m,2) == 0) then
                    fsymsign(l+1,m+1) = 1

                else
                    fsymsign(l+1,m+1) = -1

                end if

            end do

        end do

        !----------------------------------------------------------------------
        !
        !   Precompute square roots of integers that are used several times.
        !
        !----------------------------------------------------------------------
        do l = 1, 2 * lmax_comp+1
            sqr(l) = sqrt(dble(l))
        end do

        !----------------------------------------------------------------------
        !
        !   Precompute multiplicative factors used in recursion relationships
        !       P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
        !       k = l*(l+1)/2 + m + 1
        !   Note that prefactors are not used for the case when m=l as a
        !   different recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m)
        !   is assumed to be zero.
        !
        !----------------------------------------------------------------------
        select case (lnorm)
            case (1,4)
                if (lmax_comp /= 0) then
                    ff1(2,1) = sqr(3)
                    ff2(2,1) = 0.0_dp

                end if

                do l = 2, lmax_comp, 1
                    ff1(l+1,1) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
                    ff2(l+1,1) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)

                    do m = 1, l - 2, 1
                        ff1(l+1,m+1) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) &
                                       / sqr(l-m)
                        ff2(l+1,m+1) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                                       / sqr(2*l-3) / sqr(l+m) / sqr(l-m)
                    end do

                    ff1(l+1,l) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                    ff2(l+1,l) = 0.0_dp

                end do

            case(2)
                if (lmax_comp /= 0) then
                    ff1(2,1) = 1.0_dp
                    ff2(2,1) = 0.0_dp

                end if

                do l = 2, lmax_comp, 1
                    ff1(l+1,1) = dble(2*l-1) / dble(l)
                    ff2(l+1,1) = dble(l-1) / dble(l)

                    do m = 1, l - 2, 1
                        ff1(l+1,m+1) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                        ff2(l+1,m+1) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) &
                                       / sqr(l-m)

                    end do

                    ff1(l+1,l) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                    ff2(l+1,l) = 0.0_dp

                end do

            case(3)
                do l = 1, lmax_comp, 1
                    ff1(l+1,1) = dble(2*l-1) / dble(l)
                    ff2(l+1,1) = dble(l-1) / dble(l)

                    do m = 1, l - 1, 1
                        ff1(l+1,m+1) = dble(2*l-1) / dble(l-m)
                        ff2(l+1,m+1) = dble(l+m-1) / dble(l-m)

                    end do

                end do

        end select

        lmax_old = lmax_comp
        norm_old = lnorm

    end if

    !--------------------------------------------------------------------------
    !
    !   Create generic plan for gridl and gridls.
    !
    !--------------------------------------------------------------------------
    plan = fftw_plan_dft_1d(nlong, gridl(1:nlong), cc(1:nlong), &
                            FFTW_FORWARD, FFTW_MEASURE)
    plans = fftw_plan_dft_1d(nlong, gridls(1:nlong), ccs(1:nlong), &
                             FFTW_FORWARD, FFTW_MEASURE)

    !--------------------------------------------------------------------------
    !
    !   Integrate over all latitudes. Take into account symmetry of the
    !   Plms about the equator.
    !
    !--------------------------------------------------------------------------
    i_eq = n / 2 + 1  ! Index correspondong to the equator

    ! First do equator
    i = i_eq

    z = 0.0_dp
    u = 1.0_dp

    gridl(1:nlong) = grid(i,1:nlong)
    call fftw_execute_dft(plan, gridl, cc)    ! take fourier transform
    fcoef1(1:nlong) = cc(1:nlong) * sqrt(2*pi) * aj(i) / dble(nlong)

    select case (lnorm)
        case (1,2,3); pm2 = 1.0_dp
        case (4);     pm2 = 1.0_dp / sqrt(4 * pi)
    end select

    cilm(1,1,1) = cilm(1,1,1) + pm2 * fcoef1(1)

    if (lmax_comp /= 0) then
        do l = 2, lmax_comp, 2
            l1 = l + 1
            p = - ff2(l1,1) * pm2
            pm2 = p
            cilm(1,l1,1) = cilm(1,l1,1) + p * fcoef1(1)

        end do

        select case (lnorm)
            case (1,2,3); pmm = scalef
            case (4);     pmm = scalef / sqrt(4 * pi)
        end select

        rescalem = 1.0_dp / scalef

        do m = 1, lmax_comp-1, 1
            m1 = m + 1

            select case (lnorm)
                case (1,4)
                    pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                    pm2 = pmm

                case (2)
                    pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                    pm2 = pmm / sqr(2*m+1)

                case (3)
                    pmm = phase * pmm * (2*m-1)
                    pm2 = pmm

            end select

            fcoef1(m1) = fcoef1(m1) * rescalem
            fcoef1(nlong-(m-1)) = fcoef1(nlong-(m-1)) * rescalem &
                                  * ((-1)**mod(m,2))

            cilm(1,m1,m1) = cilm(1,m1,m1) + pm2 * fcoef1(m1)
            cilm(2,m1,m1) = cilm(2,m1,m1) + pm2 * fcoef1(nlong-(m-1))

            do l = m + 2, lmax_comp, 2
                l1 = l + 1
                p = - ff2(l1,m1) * pm2
                pm2 = p
                cilm(1,l1,m1) = cilm(1,l1,m1) + p * fcoef1(m1)
                cilm(2,l1,m1) = cilm(2,l1,m1) + p * fcoef1(nlong-(m-1))

            end do

        end do

        select case (lnorm)
            case (1,4)
                pmm = phase * pmm * sqr(2*lmax_comp+1) &
                      / sqr(2*lmax_comp) * rescalem

            case(2)
                pmm = phase * pmm / sqr(2*lmax_comp) * rescalem

            case(3)
                pmm = phase * pmm * (2*lmax_comp-1) * rescalem

        end select

        cilm(1,lmax_comp+1,lmax_comp+1) = cilm(1,lmax_comp+1,lmax_comp+1) &
                                          + pmm * fcoef1(lmax_comp+1)
        cilm(2,lmax_comp+1,lmax_comp+1) = cilm(2,lmax_comp+1,lmax_comp+1) &
                                          + ((-1)**mod(lmax_comp,2)) * pmm &
                                          * fcoef1(nlong-(lmax_comp-1))

    end if

    do i = 2, i_eq - 1, 1
        theta = (i-1) * pi /dble(n)
        z = cos(theta)
        u = sqrt( (1.0_dp-z) * (1.0_dp+z) )

        gridl(1:nlong) = grid(i,1:nlong)
        call fftw_execute_dft(plan, gridl, cc)    ! take fourier transform
        fcoef1(1:nlong) = cc(1:nlong) * sqrt(2*pi) * aj(i) / dble(nlong)
        ! positive frequencies up to n/2,
        ! negative frequencies beyond in oposite order

        i_s = 2 * i_eq - i

        gridls(1:nlong) = grid(i_s,1:nlong)
        call fftw_execute_dft(plans, gridls, ccs)    ! take fourier transform
        fcoef2(1:nlong) = ccs(1:nlong) * sqrt(2*pi) * aj(i_s) / dble(nlong)

        select case (lnorm)
            case (1,2,3); pm2 = 1.0_dp
            case (4); pm2 = 1.0_dp / sqrt(4 * pi)
        end select

        cilm(1,1,1) = cilm(1,1,1) + pm2 * (fcoef1(1) + fcoef2(1))
        ! fsymsign = 1

        if (lmax_comp == 0) cycle

        pm1 = ff1(2,1) * z * pm2
        cilm(1,2,1) = cilm(1,2,1) + pm1 * ( fcoef1(1) - fcoef2(1) )
        ! fsymsign = -1

        ffc1(-1) = fcoef1(1) - fcoef2(1)
        ffc1(1) = fcoef1(1) + fcoef2(1)

        do l = 2, lmax_comp, 1
            l1 = l + 1
            p = ff1(l1,1) * z * pm1 - ff2(l1,1) * pm2
            pm2 = pm1
            pm1 = p
            cilm(1,l1,1) = cilm(1,l1,1) + p * ffc1(fsymsign(l1,1))

        end do

        select case (lnorm)
            case(1,2,3); pmm = scalef
            case(4);     pmm = scalef / sqrt(4*pi)
        end select

        rescalem = 1.0_dp / scalef

        do m = 1, lmax_comp-1, 1
            m1 = m + 1
            rescalem = rescalem * u

            select case (lnorm)
                case (1,4)
                    pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                    pm2 = pmm

                case (2)
                    pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                    pm2 = pmm / sqr(2*m+1)

                case (3)
                    pmm = phase * pmm * (2*m-1)
                    pm2 = pmm

            end select

            fcoef1(m1) = fcoef1(m1) * rescalem
            fcoef1(nlong-(m-1)) = fcoef1(nlong-(m-1)) * rescalem &
                                  * ((-1)**mod(m,2))
                                  ! multiply by (-1)^m for P_{l,-m}
            fcoef2(m1) = fcoef2(m1) * rescalem
            fcoef2(nlong-(m-1)) = fcoef2(nlong-(m-1)) * rescalem &
                                  * ((-1)**mod(m,2))

            cilm(1,m1,m1) = cilm(1,m1,m1) + pm2 * ( fcoef1(m1) + fcoef2(m1) )
            cilm(2,m1,m1) = cilm(2,m1,m1) + pm2 * ( fcoef1(nlong-(m-1)) &
                            + fcoef2(nlong-(m-1)) )
                            ! fsymsign = 1

            pm1 = z * ff1(m1+1,m1) * pm2

            cilm(1,m1+1,m1) = cilm(1,m1+1,m1) + pm1 * (fcoef1(m1) - fcoef2(m1))
            cilm(2,m1+1,m1) = cilm(2,m1+1,m1) +  pm1 &
                              * ( fcoef1(nlong-(m-1)) - fcoef2(nlong-(m-1)) )
                              ! fsymsign = -1

            ffc1(-1) = fcoef1(m1) - fcoef2(m1)
            ffc1(1) = fcoef1(m1) + fcoef2(m1)
            ffc2(-1) = fcoef1(nlong-(m-1)) - fcoef2(nlong-(m-1))
            ffc2(1) = fcoef1(nlong-(m-1)) + fcoef2(nlong-(m-1))

            do l = m + 2, lmax_comp, 1
                l1 = l + 1
                p = z * ff1(l1,m1) * pm1-ff2(l1,m1) * pm2
                pm2 = pm1
                pm1 = p
                cilm(1,l1,m1) = cilm(1,l1,m1) + p * ffc1(fsymsign(l1,m1))
                cilm(2,l1,m1) = cilm(2,l1,m1) + p * ffc2(fsymsign(l1,m1))

            end do

        end do

        rescalem = rescalem * u

        select case(lnorm)
            case(1,4)
                pmm = phase * pmm * sqr(2*lmax_comp+1) &
                      / sqr(2*lmax_comp) * rescalem
            case(2);    pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            case(3);    pmm = phase * pmm * (2*lmax_comp-1) * rescalem

        end select

        cilm(1,lmax_comp+1,lmax_comp+1) = cilm(1,lmax_comp+1,lmax_comp+1) &
                                          + pmm * (fcoef1(lmax_comp+1) + &
                                          fcoef2(lmax_comp+1))
        cilm(2,lmax_comp+1,lmax_comp+1) = cilm(2,lmax_comp+1,lmax_comp+1) &
                                          + pmm * (fcoef1(nlong-(lmax_comp-1))&
                                          + fcoef2(nlong-(lmax_comp-1)))
                                          ! fsymsign = 1

    end do

    call fftw_destroy_plan(plan)
    call fftw_destroy_plan(plans)

    !--------------------------------------------------------------------------
    !
    !   Divide by integral of Ylm*Ylm
    !
    !--------------------------------------------------------------------------
    select case (lnorm)
        case(1)
            do l = 0, lmax_comp, 1
                cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) / (4*pi)

            end do

        case(2)
            do l = 0, lmax_comp, 1
                cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) * (2*l+1) / (4*pi)

            end do

        case (3)
            do l = 0, lmax_comp, 1
                prod = 4 * pi / dble(2*l+1)
                cilm(1,l+1,1) = cilm(1,l+1,1) / prod

                do m = 1, l-1, 1
                    prod = prod * (l+m) * (l-m+1)
                    cilm(1:2,l+1,m+1) = cilm(1:2,l+1,m+1) / prod

                end do

                !do m=l case
                if (l /= 0) cilm(1:2,l+1,l+1) = cilm(1:2,l+1, l+1) / (prod*2*l)

            end do

    end select

end subroutine SHExpandDHC