subroutine linreg(DX,DY,DA,DB,DR2,DN)
    implicit none
    integer*8 :: l,DN
    real*8 :: SX,SY,SXX,SXY,SYY,R,NN
    real*8,intent(out) :: DX(DN),DY(DN)
    real*8,intent(out) :: DB,DR2,DA

    SX  = 0.0
    SY  = 0.0
    SXX = 0.0
    SXY = 0.0
    SYY = 0.0

    do l=1,DN
        SX  = SX + DX(l);
        SY  = SY + DY(l);
        SXX = SXX + DX(l)*DX(l);
        SXY = SXY + DX(l)*DY(l);
        SYY = SYY + DY(l)*DY(l);
    end do
    NN  = (1.d0*DN)
    DB   = (NN*SXY-SX*SY)/(NN*SXX-SX*SX);
    DA   = (SY-DB*SX)/NN;
    R   = (NN*SXY-SX*SY)/sqrt((NN*SXX-SX*SX)*(NN*SYY-SY*SY));
    DR2  = R*R;

end subroutine linreg


      program find_modes

      parameter (max_no_depths = 5000)

      parameter (npts = max_no_depths)

      ! these parameters only influence the size of a, not the mode shape
      parameter (g = 9.8)
      parameter (rho0 = 1025.)
      parameter (small = 1e-17)
      parameter (f = 1e-4)

      real*8 zin(max_no_depths), den(max_no_depths), N(max_no_depths)
      real*8 N2

      real*8 p(npts), z, aN, dN, dp(npts)

      open (11,file='density.dat')   ! input file
      open (12,file="assign4.dat")   ! output file

      read (11,*) zin(1), den(1)
      read (11,*) zin(2), den(2)
      N2 = g * (den(2) - den(1)) / (rho0 * (zin(2) - zin(1)))
      if (N2 .lt. small) then
         N(2) = small
      else
         N(2) = sqrt(N2)
      endif
      do i = 3, max_no_depths
         read (11, *, END=999) zin(i),den(i)
         N2 = g*(den(i)-den(i-1))/(rho0 * (zin(i) - zin(i-1)))
         if (N2.lt.small) then
            N(i) = small
         else
            N(i) = sqrt(N2)
         endif
      enddo
 999  id = i - 1
      depth = zin(id)
      N(id+1) = N(id)
      N(1) = N(2)
      dz = depth/(id-1)

  100 write (*,*) 'Guess the lengthscale a?'
      write (*,*) "If you enter -1, Pi profile from last a value"
      write (*,*) " entered will be printed"
      read (*,*) a
      af = a*f
      if (a.gt.0) then
         p(id+1) = 1.
         dp(id+1) = 0.

         pmax = 1.
         do i=id+1, 2, -1
c     find the indexes of the N values above and below this depth
            Nbelow = i+1
            Nabove = i
c     linearly interpolate N
            aN = 0.5 * (N(Nabove) + N(Nbelow))
            dN = (N(Nabove) - N(Nbelow))/dz
            dp(i-1) = dp(i) + dz * (2 / aN * dN *dp(i)
     >              - p(i) * (aN * aN / af**2))
            p(i-1) = p(i) + dz * dp(i)
            if (abs(p(i-1)).gt.pmax) pmax = abs(p(i-1))
         enddo

         write (*,*) "Your a value", a,' m',
     >        " gives a dpi/dz at the surface of ",dp(1)/pmax

         goto 100
      else
         do i=1,npts
            z = dz*(i-1.)
            write (12,*) z, p(i)
         enddo
      endif

      end


!>
!! This is a routine for an interpolation between two uniform grids over the same domain
!!
!! \author Yuanfu Xie
!! \b History: Feb. 2014
!

SUBROUTINE uniform_interpolation2(nfrom,nto,vfrom,vto)

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: nfrom(2),nto(2)
  REAL,    INTENT(IN) :: vfrom(nfrom(1),nfrom(2))
  REAL,    INTENT(OUT) :: vto(nto(1),nto(2))

  ! Local variables:
  INTEGER :: indx(2,2),i,j,ii,jj
  REAL    :: coef(2,2)

  DO j=1,nto(2)
    coef(1,2) = FLOAT(nfrom(2)-1)*(j-1)/FLOAT(nto(2)-1)+1.0 ! real position from (1,nfrom)
    indx(1,2) = INT(coef(1,2))                              ! left grid
    coef(2,2) = coef(1,2)-indx(1,2)                         ! distance to left: weight on right
    indx(2,2) = MIN(indx(1,2)+1,nfrom(2))                   ! right grid
    coef(1,2) = 1.0-coef(2,2)                               ! distance to right: weight to left
  DO i=1,nto(1)
    coef(1,1) = FLOAT(nfrom(1)-1)*(i-1)/FLOAT(nto(1)-1)+1.0 ! real position from (1,nfrom)
    indx(1,1) = INT(coef(1,1))                              ! left grid
    coef(2,1) = coef(1,1)-indx(1,1)                         ! distance to left: weight on right
    indx(2,1) = MIN(indx(1,1)+1,nfrom(1))                   ! right grid
    coef(1,1) = 1.0-coef(2,1)                               ! distance to right: weight to left

    ! Interpolation:
    vto(i,j) = 0.0
    DO jj=1,2
    DO ii=1,2
      vto(i,j) = vto(i,j)+coef(ii,1)*coef(jj,2)* &
                              vfrom(indx(ii,1),indx(jj,2))
    ENDDO
    ENDDO
  ENDDO
  ENDDO

END SUBROUTINE uniform_interpolation2

SUBROUTINE uniform_interpolation3(nfrom,nto,vfrom,vto)

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: nfrom(3),nto(3)
  REAL,    INTENT(IN) :: vfrom(nfrom(1),nfrom(2),nfrom(3))
  REAL,    INTENT(OUT) :: vto(nto(1),nto(2),nto(3))

  ! Local variables:
  INTEGER :: indx(2,3),i,j,k,ii,jj,kk
  REAL    :: coef(2,3)

  DO k=1,nto(3)
    coef(1,3) = FLOAT(nfrom(3)-1)*(k-1)/FLOAT(nto(3)-1)+1.0 ! real position from (1,nfrom)
    indx(1,3) = INT(coef(1,3))                              ! left grid
    coef(2,3) = coef(1,3)-indx(1,3)                         ! distance to left: weight on right
    indx(2,3) = MIN(indx(1,3)+1,nfrom(3))                   ! right grid
    coef(1,3) = 1.0-coef(2,3)                               ! distance to right: weight to left
  DO j=1,nto(2)
    coef(1,2) = FLOAT(nfrom(2)-1)*(j-1)/FLOAT(nto(2)-1)+1.0 ! real position from (1,nfrom)
    indx(1,2) = INT(coef(1,2))                              ! left grid
    coef(2,2) = coef(1,2)-indx(1,2)                         ! distance to left: weight on right
    indx(2,2) = MIN(indx(1,2)+1,nfrom(2))                   ! right grid
    coef(1,2) = 1.0-coef(2,2)                               ! distance to right: weight to left
  DO i=1,nto(1)
    coef(1,1) = FLOAT(nfrom(1)-1)*(i-1)/FLOAT(nto(1)-1)+1.0 ! real position from (1,nfrom)
    indx(1,1) = INT(coef(1,1))                              ! left grid
    coef(2,1) = coef(1,1)-indx(1,1)                         ! distance to left: weight on right
    indx(2,1) = MIN(indx(1,1)+1,nfrom(1))                   ! right grid
    coef(1,1) = 1.0-coef(2,1)                               ! distance to right: weight to left

    ! Interpolation:
    vto(i,j,k) = 0.0
    DO kk=1,2
    DO jj=1,2
    DO ii=1,2
      vto(i,j,k) = vto(i,j,k)+coef(ii,1)*coef(jj,2)*coef(kk,3)* &
                              vfrom(indx(ii,1),indx(jj,2),indx(kk,3))
    ENDDO
    ENDDO
    ENDDO
  ENDDO
  ENDDO
  ENDDO

END SUBROUTINE uniform_interpolation3


c     program DRSBLAS4
c>> 1994-10-19 DRSBLAS4 Krogh  Changes to use M77CON
c>> 1992-05-12 DRSBLAS4 CLL Improved consistency of various versions.
c>> 1992-04-15 CLL
c>> 1992-03-16 CLL
c>> 1991-12-02 DRSBLAS4 CLL
c>> 1991-07-31 DRSBLAS4 CLL
c
c     Demonstrates the use of BLAS subroutines SROTMG, SROTM, SAXPY,
c     and SCOPY to implement an algorithm for solving a linear
c     least squares problem using sequential accumulation of the
c     data and Modified (Fast) Givens orthogonal transformations.
c     YTAB() contains rounded values of -2 + 2*X + 3*Exp(-X)
c
c     ------------------------------------------------------------------
c--S replaces "?": DR?BLAS4, ?AXPY, ?ROTMG, ?ROTM, ?COPY, ?VECP
c     ------------------------------------------------------------------
      integer MC, MC1, MC2, MXY
      parameter ( MC=3, MC1=MC+1, MC2=MC+2, MXY=11 )
      real             XTAB(MXY), YTAB(MXY), W(MC2), RG(MC1,MC2)
      real             C(MC), ZERO(1), X, Y, ESTSD, DIV, PARAM(5)
      real             ONE(1)
      integer NXY, NC, NC1, NC2, IXY, J
c
      data XTAB / 0.0e0, .1e0, .2e0, .3e0, .4e0, .5e0, .6e0, .7e0,
     *           .8e0, .9e0, 1.0e0 /
      data YTAB / 1.00e0, .91e0, .86e0, .82e0, .81e0, .82e0, .85e0,
     * .89e0, .95e0, 1.02e0, 1.10e0 /
      data NXY, NC / 11, 3 /
      data ONE(1), ZERO(1) / 1.0e0, 0.0e0 /
c     ------------------------------------------------------------------
      print'(a/)',' DRSBLAS4..  Demo for SROTMG and SROTM.'
      NC1 = NC + 1
      NC2 = NC1 + 1
      call SCOPY(MC1*MC2, ZERO, 0, RG, 1)
      call SCOPY(NC1, ONE, 0, RG(1,NC2), 1)
      do 20 IXY = 1, NXY
        X = XTAB(IXY)
        Y = YTAB(IXY)
c
c          Set W() to be the next row of the least-squares problem.
c
        W(1) = 1.0e0
        W(2) = X
        W(3) = EXP(-X)
        W(4) = Y
        W(5) = 1.0E0
c
c        Accumulate W() into the triangular matrix [R:G]
c        using Givens rotations.
c
        do 10 J = 1, NC1
          call SROTMG(RG(J,NC2), W(NC2), RG(J,J), W(J), PARAM)
          if(J .lt. NC1) call SROTM(NC1-J,RG(J,J+1),MC1,W(J+1),1,PARAM)
   10   continue
c
   20 continue
c
c               Solve the triangular system.
c
        call SCOPY(NC,RG(1,NC1),1,C,1)
        do 30 J = NC, 1, -1
          DIV = RG(J,J)
          if (DIV .EQ. 0.0e0) then
            print*,'ERROR:ZERO DIVISOR AT J =',J
            stop
          end if
          C(J) = C(J) / DIV
          call SAXPY(J-1,-C(J),RG(1,J),1,C,1)
   30 continue
c
      call SVECP(C,NC,'0 Solution: C()=')
      print*,' '
      ESTSD = abs(RG(NC1,NC1)) * sqrt(RG(NC1,NC2)) / sqrt(REAL(NXY-NC))
      print*,'Estimated STD. DEV. of data errors =',ESTSD
      stop
      end


SUBROUTINE calc_amp_phase(c, amp, theta)
COMPLEX, INTENT(IN) :: c
REAL, INTENT(OUT) :: amp, theta
REAL :: r, i
r = REAL(c)
i = AIMAG(c)
amp = CABS(c)
theta = ATAN2D(r, i)
END SUBROUTINE calc_amp_phase

PROGRAM amp_and_phase
IMPLICIT NONE
COMPLEX :: c
REAL :: amp, theta
WRITE(*, *) "Enter a complex number: "
READ(*, *) c
CALL calc_amp_phase(c, amp, theta)
WRITE(*, *) c, amp, theta
END PROGRAM amp_and_phase


program test_Reuss_av
!===============================================================================
!  Test the CIJ_Reuss_av subroutine

use anisotropy_ajn

implicit none

real(8) :: C(5,6,6),rh(5),VF(5)
real(8) :: CReuss(6,6),rhReuss
real(8) :: CTrue(6,6)
integer :: n,ii,jj

!  Set density to be the same for all values
rh = 5500.

!  Set equal weighting for all values--this will be normalised in the subroutine.
VF = 1.

!  Create 5 arrays filled with:
!     1     1     1     1     1     1
!     1     2     2     2     2     2
!     1     2     3     3     3     3   x   {1..5}
!     1     2     3     4     4     4
!     1     2     3     4     5     5
!     1     2     3     4     5     6
!
!  The Reuss average is an array filled with the harmonic mean of each element:
CTrue = reshape( &
    [ 2.1898,   2.1898,   2.1898,   2.1898,   2.1898,   2.1898, &
      2.1898,   4.3796,   4.3796,   4.3796,   4.3796,   4.3796, &
      2.1898,   4.3796,   6.5693,   6.5693,   6.5693,   6.5693, &
      2.1898,   4.3796,   6.5693,   8.7591,   8.7591,   8.7591, &
      2.1898,   4.3796,   6.5693,   8.7591,  10.9489,  10.9489, &
      2.1898,   4.3796,   6.5693,   8.7591,  10.9489,  13.1387  ], [6,6])
!  If no F2008-compatible compiler around, change the [ ] for (/ /).

do n=1,5
   do ii=1,6
      do jj=ii,6
         C(n,ii,jj) = real(n*ii)
         C(n,jj,ii) = C(n,ii,jj)
      enddo
   enddo
enddo

call CIJ_Reuss_av(VF,C,rh,CReuss,rhReuss)

write(*,'(a)') '====== Testing CIJ_Reuss_av ======'
write(*,'(a)') 'Expected output:'
write(*,'(6(f5.1))') CTrue
write(*,'(a)') ''
write(*,'(a)') 'Reuss average:'
write(*,'(6(f5.1))') CReuss
write(*,'(a)') '=================================='

end program


\ calculate factorial using recursion
: fac ( n -- fac_n )
  dup 2 < if
    drop 1                \ fac(0) = fac(1) = 1
  else
    dup 1 - recurse *     \ fac(n) = n * fac(n-1)
  then
;
.( fac of 10 is ) 10 fac .


    Program dspgst_example

!     DSPGST Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dpptrf, dspgst, dsptrd, dsterf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, j, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ap(:), bp(:), d(:), e(:), tau(:)
!     .. Executable Statements ..
      Write (nout, *) 'DSPGST Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (ap(n*(n+1)/2), bp(n*(n+1)/2), d(n), e(n-1), tau(n))

!     Read A and B from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)((ap(i+j*(j-1)/2),j=i,n), i=1, n)
        Read (nin, *)((bp(i+j*(j-1)/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
        Read (nin, *)((bp(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
      End If

!     Compute the Cholesky factorization of B
      Call dpptrf(uplo, n, bp, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'B is not positive definite.'
      Else

!       Reduce the problem to standard form C*y = lambda*y, storing
!       the result in A
        Call dspgst(1, uplo, n, ap, bp, info)

!       Reduce C to tridiagonal form T = (Q**T)*C*Q
        Call dsptrd(uplo, n, ap, d, e, tau, info)

!       Calculate the eigenvalues of T (same as C)
        Call dsterf(n, d, e, info)

        If (info>0) Then
          Write (nout, *) 'Failure to converge.'
        Else

!         Print eigenvalues

          Write (nout, *) 'Eigenvalues'
          Write (nout, 100) d(1:n)
        End If
      End If

100   Format (3X, (9F8.4))
    End Program


! Temporary module, a subset of lfortran_intrinsic_math that works
module lfortran_intrinsic_math2
use, intrinsic :: iso_fortran_env, only: i32 => int32, sp => real32, dp => real64
implicit none

interface abs
    module procedure iabs, sabs, dabs, cabs, zabs
end interface

interface sqrt
    module procedure ssqrt, dsqrt
end interface

interface aimag
    module procedure saimag, daimag
end interface

interface floor
    module procedure sfloor, dfloor
end interface

interface ceiling
    module procedure sceiling, dceiling
end interface

interface nint
    module procedure snint, dnint
end interface

interface modulo
    module procedure imodulo, smodulo, dmodulo
end interface

interface mod
    module procedure imod, smod, dmod
end interface

interface min
    module procedure imin, smin, dmin, imin_6args
end interface

interface max
    module procedure imax, smax, dmax, imax_6args
end interface

interface huge
    module procedure i32huge, sphuge, dphuge
end interface

contains

! abs --------------------------------------------------------------------------

elemental integer function iabs(x) result(r)
integer, intent(in) :: x
if (x >= 0) then
    r = x
else
    r = -x
end if
end function

elemental real(sp) function sabs(x) result(r)
real(sp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = -x
end if
end function

elemental real(dp) function dabs(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = -x
end if
end function

elemental real(sp) function cabs(x) result(r)
complex(sp), intent(in) :: x
r = 1.0
end function

elemental real(dp) function zabs(x) result(r)
complex(dp), intent(in) :: x
r = 1.0
end function

! sqrt -------------------------------------------------------------------------

elemental real(sp) function ssqrt(x) result(r)
real(sp), intent(in) :: x
if (x >= 0) then
    r = x**(1._sp/2)
else
    error stop "sqrt(x) for x < 0 is not allowed"
end if
end function

elemental real(dp) function dsqrt(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x**(1._dp/2)
else
    error stop "sqrt(x) for x < 0 is not allowed"
end if
end function

! aimag ------------------------------------------------------------------------

elemental real(sp) function saimag(x) result(r)
complex(sp), intent(in) :: x
r = 3
! Uncomment once it is implemented
!r = x%im
!error stop "aimag not implemented yet"
end function

elemental real(dp) function daimag(x) result(r)
complex(dp), intent(in) :: x
r = 3
! Uncomment once it is implemented
!r = x%im
!error stop "aimag not implemented yet"
end function

! floor ------------------------------------------------------------------------

elemental integer function sfloor(x) result(r)
real(sp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = x-1
end if
end function

elemental integer function dfloor(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = x-1
end if
end function

! ceiling ------------------------------------------------------------------------

elemental integer function sceiling(x) result(r)
real(sp), intent(in) :: x
r = sfloor(x)
if (r - x /= 0.0) then
    r = r + 1
end if
end function

elemental integer function dceiling(x) result(r)
real(dp), intent(in) :: x
r = dfloor(x)
if (r - x /= 0.0) then
    r = r + 1
end if
end function

! nint ------------------------------------------------------------------------

elemental integer function snint(x) result(r)
real(sp), intent(in) :: x
if (x >= 0) then
    r = x+0.5_sp
else
    r = x-1+0.5_sp
end if
end function

elemental integer function dnint(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x+0.5_dp
else
    r = x-1+0.5_dp
end if
end function

! modulo -----------------------------------------------------------------------

elemental integer function imodulo(x, y) result(r)
integer, intent(in) :: x, y
r = x-floor(real(x)/y)*y
end function

elemental real(sp) function smodulo(x, y) result(r)
real(sp), intent(in) :: x, y
r = x-floor(x/y)*y
end function

elemental real(dp) function dmodulo(x, y) result(r)
real(dp), intent(in) :: x, y
r = x-floor(x/y)*y
end function

! mod --------------------------------------------------------------------------

elemental integer function imod(x, y) result(r)
integer, intent(in) :: x, y
r = x-floor(real(x)/y)*y
if (x < 0 .and. y < 0) return
if (x < 0) r = r - y
if (y < 0) r = r - y
end function

elemental real(sp) function smod(x, y) result(r)
real(sp), intent(in) :: x, y
r = x-floor(x/y)*y
if (x < 0 .and. y < 0) return
if (x < 0) r = r - y
if (y < 0) r = r - y
end function

elemental real(dp) function dmod(x, y) result(r)
real(dp), intent(in) :: x, y
r = x-floor(x/y)*y
if (x < 0 .and. y < 0) return
if (x < 0) r = r - y
if (y < 0) r = r - y
end function

! min --------------------------------------------------------------------------

elemental integer function imin(x, y) result(r)
integer, intent(in) :: x, y
if (x < y) then
    r = x
else
    r = y
end if
end function

elemental real(sp) function smin(x, y) result(r)
real(sp), intent(in) :: x, y
if (x < y) then
    r = x
else
    r = y
end if
end function

elemental real(dp) function dmin(x, y) result(r)
real(dp), intent(in) :: x, y
if (x < y) then
    r = x
else
    r = y
end if
end function

elemental integer function imin_6args(a, b, c, d, e, f) result(r)
integer, intent(in) :: a, b, c, d, e, f
integer :: args(6)
integer :: itr, curr_value
args(1) = a
args(2) = b
args(3) = c
args(4) = d
args(5) = e
args(6) = f
r = a
do itr = 1, 6
    curr_value = args(itr)
    r = min(curr_value, r)
end do
end function

! max --------------------------------------------------------------------------

elemental integer function imax(x, y) result(r)
integer, intent(in) :: x, y
if (x > y) then
    r = x
else
    r = y
end if
end function

elemental integer function imax_6args(a, b, c, d, e, f) result(r)
integer, intent(in) :: a, b, c, d, e, f
integer :: args(6)
integer :: itr, curr_value
args(1) = a
args(2) = b
args(3) = c
args(4) = d
args(5) = e
args(6) = f
r = a
do itr = 1, 6
    curr_value = args(itr)
    r = imax(curr_value, r)
end do
end function

elemental real(sp) function smax(x, y) result(r)
real(sp), intent(in) :: x, y
if (x > y) then
    r = x
else
    r = y
end if
end function

elemental real(dp) function dmax(x, y) result(r)
real(dp), intent(in) :: x, y
if (x > y) then
    r = x
else
    r = y
end if
end function

! huge -------------------------------------------------------------------------

elemental integer(i32) function i32huge(x) result(r)
integer(i32), intent(in) :: x
r = 2147483647
! r = 2**31 - 1
end function

elemental real(sp) function sphuge(x) result(r)
real(sp), intent(in) :: x
r = 3.40282347e38
! r = 2**128 * (1 - 2**-24)
end function

elemental real(dp) function dphuge(x) result(r)
real(dp), intent(in) :: x
r = 1.7976931348623157d308
! r = 2**1024 * (1 - 2**-53)
end function

end module


! Transformation functions
      subroutine ecef_to_geodetic(pos, latitude, lon, h)
      ! converts from ECEF coordinates to Geodetic
      ! pos is the 3 element array of positions in km
      ! latitude returned in Radians
      ! longitude returned in Radians
      ! h is the geodetic altitude, returned in km

      ! pos is (x,y,z) in ECEF coordinates
      real*8, dimension(3) :: pos
      real*8 a,b,ellip,e2,p,e_prime,theta,latitude,r_n,h
      real*8 lon
      real*8 pi

cf2py intent(in) pos
Cf2py intent(out) latitude, lon, h

      pi = 4.D0*DATAN(1.D0)
      ! interpret height as geodetic limit
      ! take current position in lat,lon, and final height
      ! convert to ECEF and use as a limit
      ! equivalent geocentric height
      ! closed form solution
      b = 6356.75231424518d0
      a = 6378.1370d0
      ellip = dsqrt(1.d0-b**2/a**2)
      ! first eccentricity squared
      e2 = ellip**2 !6.6943799901377997E-3
      ! radial position from z, think rho and cylindrical coords
      p = dsqrt(pos(1)**2+pos(2)**2)
      e_prime = dsqrt((a**2-b**2)/b**2)
      theta = datan(pos(3)*a/(p*b))
      latitude = datan( (pos(3)+e_prime**2*b*dsin(theta)**3)/
     &(p-ellip**2*a*dcos(theta)**3))

      r_n = a/dsqrt(1.d0-ellip**2*dsin(latitude)**2)
      ! geodetic height
      h = p/dcos(latitude) - r_n

      lon = datan(pos(2)/pos(1))
      ! Based on values from atan2() from Python
      if (pos(1).lt.0) then
         if (pos(2).lt.0) lon=lon-pi
         if (pos(2).ge.0) lon=lon+pi
      end if
      if (pos(1).eq.0) then
         if (pos(2).gt.0) lon=lon+pi/2.D0
         if (pos(2).lt.0) lon=lon-pi/2.D0
      end if

      return
      end

      subroutine end_vector_to_ecef(be,bn,bd,colat,elong,bx,by,bz)
      ! inputs are east, north, and down components
      ! colatitude (radians, 0 at northern pole)
      ! longitude (radians)
      ! mag field values
      real*8 colat,elong,bn,be,bd,lat
      ! position values of point
      real*8 bx,by,bz
      real*8 pi

cf2py intent(in) be, bn, bd, colat, elong
Cf2py intent(out)  bx, by, bz

      pi = 4.D0*DATAN(1.D0)
      lat = pi/2.D0 - colat
      ! convert the mag field in spherical unit vectors to ECEF
      !bx=-bd*dsin(colat)*dcos(elong)-bn*dcos(colat)*dcos(elong)
      bx=-bd*dcos(lat)*dcos(elong)-bn*dsin(lat)*dcos(elong)
      bx=bx-be*dsin(elong)
      by=-bd*dcos(lat)*dsin(elong)-bn*dsin(lat)*dsin(elong)
      by=by+be*dcos(elong)
      bz=-bd*dsin(lat)+bn*dcos(lat)

      return
      end

      subroutine ecef_to_colat_long_r(pos, colat, elong, r)
      ! pos is (x,y,z) in ECEF coordinates
      real*8, dimension(3) :: pos
      ! position values of point
      real*8 r, colat, elong
      ! height to stop integration at
      real*8 pi
      pi = 4.D0*DATAN(1.D0)

cf2py intent(in) pos
Cf2py intent(out) colat, elong, r

      ! calculate longitude, colatitude, and altitude from ECEF position
      ! altitude should be radial distance from center of earth
      r = dsqrt(pos(1)**2+pos(2)**2+pos(3)**2)
      colat = dacos(pos(3)/r)
      elong = datan(pos(2)/pos(1))

      ! Based on values from atan2() from Python
      ! Based on values from atan2() from Python
      if (pos(1).lt.0) then
         if (pos(2).lt.0) elong=elong-pi
         if (pos(2).ge.0) elong=elong+pi
      end if
      if (pos(1).eq.0) then
         if (pos(2).gt.0) elong=elong+pi/2.D0
         if (pos(2).lt.0) elong=elong-pi/2.D0
      end if

      return
      end

      subroutine ecef_to_end_vector(x,y,z,colat,elong,vn,ve,vd)
      ! Vector expressed along ECEF returned along END directions
      !
      ! inputs are x, y, and z ECEF components
      ! colatitude (radians, 0 at northern pole)
      ! longitude (radians)
      ! outputs are vn, ve, vd components

      real*8 x,y,z,colat,elong,ve,vn,vd,pi,lat
      pi = 4.D0*DATAN(1.D0)
      lat = pi/2.D0 - colat

      ve = -x*dsin(elong) + y*dcos(elong)
      vn = -x*dcos(elong)*dsin(lat)-y*dsin(elong)*dsin(lat)+z*dcos(lat)
      vd = -x*dcos(elong)*dcos(lat)-y*dsin(elong)*dcos(lat)-z*dsin(lat)

      return
      end

      subroutine colat_long_r_to_ecef(pos, colat, elong, r)
      ! Convert position in geocentric to ECEF
      ! pos is (x,y,z) in ECEF coordinates
      real*8, dimension(3) :: pos
      ! position values of point
      real*8 r, colat, elong, x, y, z

cf2py intent(out) pos
Cf2py intent(in) colat, elong, r

      x = r * dsin(colat) * dcos(elong)
      y = r * dsin(colat) * dsin(elong)
      z = r * dcos(colat)
      pos = (/x, y, z/)

      return
      end

      subroutine dipole_field(pos, offs, m, b)
      ! returns magnetic field from dipole
      ! pos, location where field is returned, is (x, y, z) ECEF in km
      ! offs, offset location of dipole from origin, (x, y, z) ECEF in km
      ! m is (mx, my, mz)
      ! b, calculated magnetic field, (bx, by, bz)

      real*8, dimension(3) :: pos, offs, m, b, r, rhat
      real*8 mu_r3, r3, rmag

      ! eqn is mu/4(pi)*( 3n(n dot m) - m)/r**3

      ! construct vector to dipole
      ! put in terms in meters
      do i=1,3
        r(i) = (pos(i) - offs(i)) * 1000.D0
      end do

      ! position unit vector (n)
      rmag = dsqrt(r(1)**2 + r(2)**2 + r(3)**2)
      do i=1,3
        rhat(i) = r(i) / rmag
      end do

      ! n dot m term
      rm = rhat(1) * m(1) + rhat(2) * m(2) + rhat(3) * m(3)
      ! r**3 term
      r3 = rmag**3
      ! mu / 4 pi / |r**3|
      mu_r3 = 1.D-7 / r3

      ! calculate magnetic field
      do i=1,3
        b(i) = mu_r3 * (3.D0 * rm * rhat(i) - m(i))
      end do

      return
      end

      subroutine linear_quadrupole(pos, offs, m, step, b)
      ! returns magnetic field from linear quadrupole
      ! pos, location where field is returned, (x, y, z) ECEF in km
      ! offs, offset location of quadrupole from origin, (x, y, z) ECEF in km
      ! sep, distance from quadrupole origin for underlying dipoles (km)
      ! m is magnetic moment of primary underlying dipoles (vector)
      ! b, calculated magnetic field, (bx, by, bz)
      real*8, dimension(3) :: pos, offs, b, temp_b, temp_m, temp_o, m
      real*8, dimension(3) :: um
      real*8 :: step, mag, scalar

      ! Calculate step vector. Get unit mag vector then step along.
      mag = dsqrt(m(1) * m(1) + m(2) * m(2) + m(3) * m(3))
      scalar = step / mag
      do i=1,3
        um(i) = m(i) * scalar
      enddo

      ! Take step, from offs, along magnetic moment direction
      do i=1,3
        temp_o(i) = offs(i) + um(i)
      enddo

      call dipole_field(pos, temp_o, m, temp_b)
      b(1) = temp_b(1)
      b(2) = temp_b(2)
      b(3) = temp_b(3)

      ! Underlying dipoles arranged along moment direction
      ! Take opposite step, from offs, as first dipole.
      do i=1,3
        temp_o(i) = offs(i) - um(i)
      enddo
      ! Reversed moment.
      temp_m = (/ -1.D0 * m(1), -1.D0 * m(2), -1.D0 * m(3) /)

      call dipole_field(pos, temp_o, temp_m, temp_b)
      b(1) = b(1) + temp_b(1)
      b(2) = b(2) + temp_b(2)
      b(3) = b(3) + temp_b(3)

      return
      end

      subroutine poles (flag,isv,date,itype,alt,colat,elong,x,y,z,f)
      ! Generate magnetic field for testing purposes
      ! Function signature needs to mostly match that of igrfsyn
      ! flag indicates which magnetic field source to produce.
      ! 0 : Dipole only field
      ! 1 : Dipole + Linear Quadrupole along ECEF +Z
      ! 2 : Dipole + Linear Quadrupole along ECEF +X
      ! 3 : Dipole + Normal Quadrupole, equatorial plane
      ! 4 : Dipole + Normal Octupole, equatorial plane
      ! isv, date not used
      real*8, dimension(3) :: bdip, bq, m, offs, pos, tbq
      real*8 x, y, z, f ! field along east, north, down, magnitude
      real*8 vx, vy, vz ! field along ECEF x, y, z
      real*8 alt, colat, elong, date, mag
      integer isv, itype, flag

C following added by RStoneback
Cf2py intent(in) flag,isv,date,itype,alt,colat,elong
Cf2py intent(out) x,y,z,f

      ! Convert inputs to ECEF
      if (itype.eq.2) then
        call colat_long_r_to_ecef(pos, colat, elong, alt)
      end if

      ! Calculate dipole magnetic field
      offs = (/0.0D0, 0.0D0, 0.0D0/)
      m = (/0.D0, 0.D0, -8.D22/)
      call dipole_field(pos, offs, m, bdip)

      ! Initialize memory for quadrupole
      bq = (/ 0.D0, 0.D0, 0.D0 /)

      if (flag.eq.1) then
          ! assymetrical northern hemisphere via linear quadrupole
          m = (/0.D0, 0.D0, -2.37D22/)
          call linear_quadrupole(pos, offs, m, 1000.D0, tbq)
          do i=1,3
           bq(i) = bq(i) + tbq(i)
          enddo
      elseif (flag.eq.2) then
          ! linear quad, equatorial plane
          m = (/2.37D21, 0.D0, 0.D0/)
          call linear_quadrupole(pos, offs, m, 1000.D0, tbq)
          do i=1,3
           bq(i) = bq(i) + tbq(i)
          enddo
      elseif (flag.eq.3) then
          ! normal quad, equatorial plane
          m = (/2.37D21, 0.D0, 0.D0/)
          call linear_quadrupole(pos, offs, m, 1000.D0, tbq)
          do i=1,3
           bq(i) = bq(i) + tbq(i)
          enddo

          m = (/0.D0, 2.37D21, 0.D0/)
          call linear_quadrupole(pos, offs, m, -1000.D0, tbq)
          do i=1,3
           bq(i) = bq(i) + tbq(i)
          enddo
      elseif (flag.eq.4) then
          ! normal octupole, equatorial plane
          mag = 1.D20
          m = (/mag, mag, 0.D0/)
          offs = (/0.0D0, 0.0D0, 1000.0D0/)
          call linear_quadrupole(pos, offs, m, -1000.D0, tbq)
          do i=1,3
           bq(i) = bq(i) + tbq(i)
          enddo

          m = (/-mag, mag, 0.D0/)
          call linear_quadrupole(pos, offs, m, 1000.D0, tbq)
          do i=1,3
           bq(i) = bq(i) + tbq(i)
          enddo

          m = (/mag, mag, 0.D0/)
          offs = (/0.0D0, 0.0D0, -1000.0D0/)
          call linear_quadrupole(pos, offs, m, -1000.D0, tbq)
          do i=1,3
           bq(i) = bq(i) + tbq(i)
          enddo

          m = (/-mag, mag, 0.D0/)
          call linear_quadrupole(pos, offs, m, 1000.D0, tbq)
          do i=1,3
           bq(i) = bq(i) + tbq(i)
          enddo
      end if

      ! Combine dipole and quadrupole contributions
      vx = bdip(1) + bq(1)
      vy = bdip(2) + bq(2)
      vz = bdip(3) + bq(3)
      f = dsqrt(vx**2 + vy**2 + vz**2)

      ! Rotate field into north, east, vertical (down) components
      call ecef_to_end_vector(vx,vy,vz,colat,elong,x,y,z)

      return
      end

      subroutine gen_step(mflag,gflag,out,pos,t,date,step,dir,height)
      ! Generalized integrand field-line step function for testing

      ! IGRF call
      external :: igrf13syn
      ! pos is (x,y,z) in ECEF coordinates
      real*8, dimension(3) :: pos
      ! t is total time supplied by integration routine, ignored
      ! date is year.fractional_doy
      real*8 t, date
      ! step size along field (km)
      real*8 step
      ! Flag for integration direction
      ! +1 Field line direction, -1 anti-field-aligned
      real*8 dir
      ! Height to stop integration at
      real*8 height
      ! Flag for type of magnetic field. -1 for IGRF.
      ! See `poles` for fields returned for 1 and higher.
      integer mflag
      ! Flag for geodetic(0) or geocentric(1)
      integer gflag
      ! output position info
      real*8, dimension(3) :: out

      ! internal function values
      ! mag field values
      real*8 bx,by,bz,bn,be,bd,bm
      ! position values
      real*8 r, colat, elong, h, latitude

cf2py intent(in) mflag,gflag,pos,t,date,step,dir,height
Cf2py intent(out) out

      ! Calculate longitude, colatitude, and altitude from ECEF position
      ! Altitude should be radial distance from center of earth
      call ecef_to_colat_long_r(pos,colat,elong,r)

      ! Calculate magnetic field value
      if (mflag.eq.-1) then
        ! Use IGRF. Supported to ensure reults same as operational
        ! IGRF function.
        call igrf13syn(0,date,2,r,colat,elong,bn,be,bd,bm)
      else
        ! Use a physically specified dipole + higher order poles
        call poles(mflag,0,date,2,r,colat,elong,bn,be,bd,bm)
      end if

      ! Convert the mag field in spherical unit vectors to ECEF vectors
      call end_vector_to_ecef(be,bn,bd,colat,elong,bx,by,bz)

      ! Get updated position, we need to know when to terminate
      if (gflag.eq.0) then
        ! Geodetic Earth
        call ecef_to_geodetic(pos, latitude, elong, h)
      else
        ! Geocentric Earth
        h = r - 6371.D0
      end if

      ! Stop moving position if we go below height
      if (h.le.(height)) then
        step = 0
      else if (h.le.(height+step)) then
        step = step*(1. - ((height+step - h)/step)**2)
      end if

      ! Take step
      bm = 1.D0 / bm
      out(1) = dir * step * bx * bm
      out(2) = dir * step * by * bm
      out(3) = dir * step * bz * bm

      return
      end

      subroutine igrf_step(out,pos,t,date,scalar,dir,height)

      ! IGRF call
      external :: igrf13syn

      real*8, dimension(3) :: pos
      real*8 t, date

      ! pos is (x,y,z) in ECEF coordinates
      ! t is time supplied by integration routine

      ! mag field values
      real*8 bx,by,bz,bn,be,bd,bm
      ! position values of point
      real*8 r, colat, elong
      ! output position info
      real*8, dimension(3) :: out
      ! scalar for how big of a step size (km)
      real*8 scalar
      ! scalar for integration direction (+/- 1)
      real*8 dir
      ! height to stop integration at
      real*8 height
      real*8 pi
      ! parameters for geodetic to ecef calc
      real*8 a,b,ellip,e2,p,e_prime,theta,latitude,r_n,h
      pi = 4.D0*DATAN(1.D0)

cf2py intent(in) pos,t,date,scalar,dir,height
Cf2py intent(out) out

      ! calculate longitude, colatitude, and altitude from ECEF position
      ! altitude should be radial distance from center of earth
      call ecef_to_colat_long_r(pos,colat,elong,r)

      call igrf13syn(0,date,2,r,colat,elong,bn,be,bd,bm)

      ! convert the mag field in spherical unit vectors to ECEF vectors
      call end_vector_to_ecef(be,bn,bd,colat,elong,bx,by,bz)

      ! get updated geodetic position, we need to know
      ! when to terminate
      call ecef_to_geodetic(pos, latitude, elong, h)

      ! stop moving position if we go below height
      if (h.le.(height)) then
        scalar = 0
      else if (h.le.(height+scalar)) then
        scalar = scalar*(1. - ((height+scalar - h)/scalar)**2)
      end if

      out(1) = dir*scalar*bx/bm
      out(2) = dir*scalar*by/bm
      out(3) = dir*scalar*bz/bm

      return
      end


      DOUBLE PRECISION FUNCTION darcdis (long1, lat1, long2, lat2)
!     Function to compute the distance between two latitude, longitude
!       points in nautical miles.
!     Algorithm from Doug MacAyeal, The University of Chicago, 1985.
!     Bullet-proofing added by Robert Grumbine 6 April 1994.
!     Returns -1 in event of errors.  Diagnostic printout eliminated.
!       Robert Grumbine 15 September 2005

      IMPLICIT none

      DOUBLE PRECISION ab, ac, bc, arg
      DOUBLE PRECISION lat1, long1, lat2, long2

      DOUBLE PRECISION pi, rdpdg, rearth
      PARAMETER (pi = 3.141592654)
      PARAMETER (rdpdg = pi / 180.)
      PARAMETER (rearth = 6370.949e3)

!     Bullet-proofing: Check that lats are within +- 90, longs
!       longs are within +- 360.
      IF (ABS(lat1) .GT. 90. .OR. ABS(lat2) .GT. 90.) THEN
          darcdis = -1.
          RETURN
      ENDIF
      IF (ABS(long1) .GT. 360. .OR. ABS(long2) .GT. 360.) THEN
          darcdis = -1.
          RETURN
      ENDIF

!     Operational Code
!     Special case included because trig round off can give identical
!      points a nonzero separating distance. BG 6/3/93.
      IF (long1 .EQ. long2 .AND. lat1 .EQ. lat2) THEN
        darcdis = 0.0
        RETURN
      ENDIF

      ab = (90.-lat1)*rdpdg
      ac = (90.-lat2)*rdpdg
      bc = ABS((long1-long2)*rdpdg)
!     arg introduced 6/3/93 to proof against the special case that
!       round-off errors in trig produce a value for the argument
!       which is out of bounds for the arc-cosine function.  This
!       should be rare though not totally impossible.
      arg = DCOS(ab)*DCOS(ac)+DSIN(ab)*DSIN(ac)*DCOS(bc)
      IF (arg .GT.  1.0) THEN
        arg =  1.0
      ENDIF
      IF (arg .LT. -1.0) THEN
        arg = -1.0
      ENDIF
      darcdis = DACOS(arg)*rearth

!     Bullet-proofing: Verify that distance is less than circumference
!       of the earth.
      IF (darcdis .GT. 2.*pi*rearth) THEN
        darcdis = -1
        RETURN
      ENDIF

      RETURN
      END


program moving
	use kind_defs
	implicit none
	interface
		function moving_average(X, F) result (Y)
			use kind_defs
			implicit none
			real(dbl), intent(in) :: X(:)
			integer, intent(in) :: F
			real(dbl) :: Y(size(X))
		end function
	end interface
	integer, parameter :: N = 5000
	real(dbl) :: X(N), Y(N), ran
	integer :: i

	X(1) = 0
	do i = 2,N
		!call random_seed()
		call random_number(ran)
		X(i) = X(i-1) + (ran-0.5)*10
	enddo

	Y = moving_average(X, 100)

	open(50, file='mm.dat', status='replace', action='write')
	do i = 1,N
		write(50, '(2f20.8)') X(i), Y(i)
	enddo
	close(50)
end program

function moving_average(X, F) result (Y)
	use kind_defs
	implicit none
	real(dbl), intent(in) :: X(:)
	integer, intent(in) :: F
	real(dbl) :: Y(size(X))
	integer :: N, Wwidth, i
	real(dbl) :: cumsum

	N = size(X)
	Wwidth = 2*F + 1                     ! filter width

	! Boxcar window of length 2F+1 via recursive moving average (really fast)
	! Moving average method, except the ends:
	if (F == 0) then
		Y = X
	else
		Y(F+1) = sum(X(1:Wwidth))
		do i = F+2,N-F
			Y(i) = Y(i-1) + X(i+F) - X(i-F-1)   ! recursive moving average
		enddo
		Y = Y/Wwidth
	endif

	! Smooths the ends:
	! First end:
	!Yini = cumsum(X(1:Wwidth-2))
	!Yini = Yini(1:2:end)./(1:2:Wwidth-2)
	!Y(1:F) = Yini

	! Last end:
	!Yfin = cumsum(X(N:-1:N-Wwidth+3));
	!Yfin = Yfin(end:-2:1)./(Wwidth-2:-2:1)
	!Y(N-F+1:N) = Yfin

	! My FORTRAN-version:
	Y(1) = X(1)
	Y(2) = (X(1)+X(2))/2
	cumsum = X(1)+X(2)
	do i = 3,Wwidth-2,2
		cumsum = cumsum + X(i-1) + X(i)
		Y((i+1)/2) = cumsum / i
	enddo

	! Last end:
	Y(N) = X(N)
	Y(N-1) = (X(N)+X(N-1))/2
	cumsum = X(N)+X(N-1)
	do i = N,N-Wwidth+3,-2
		cumsum = cumsum + X(i-1) + X(i)
		Y((i+1)/2) = cumsum / i
	enddo

end function


        SUBROUTINE LAIS(FL,di,PD,EMP1,EMP2,N,nb,SWFAC1,SWFAC2,PT,
     &         dN,p1, sla, dLAI)

!-----------------------------------------------------------------------
        IMPLICIT NONE
        REAL PD,EMP1,EMP2,N,nb,dLAI, SWFAC,a, dN, p1,sla
        REAL SWFAC1, SWFAC2, PT, di, FL
!-----------------------------------------------------------------------

        SWFAC = MIN(SWFAC1, SWFAC2)
        IF (FL .EQ. 1.0) THEN
            a = exp(EMP2 * exp(N-nb))
            DO WHILE (1.0+a.GT.1.0)
                a=a/2.0
            END DO
            a=a*2
            dLAI = SWFAC * PD * EMP1 * PT * (a/(1+a)) * dN
        ELSEIF (FL .EQ. 2.0) THEN

            dLAI = - PD * di * p1 * sla

        ENDIF
!-----------------------------------------------------------------------
        RETURN
        END SUBROUTINE LAIS

        PROGRAM MAIN
        IMPLICIT NONE

        REAL nb,N,PT,di,p1,sla
        REAL PD,EMP1,EMP2
        REAL dn,dLAI, FL

        REAL SWFAC1, SWFAC2

        FL = 1.0
        nb = 2.5
        di = 1.0
        PD = 2.0
        EMP1 = 2.0
        EMP2 = 2.0
        N = 2.5
        SWFAC1 = 5.5
        SWFAC2 = 4.5
        PT = 1.0
        dN = 2.5
        p1 = 1.0
        sla = 1.0

        CALL LAIS(FL,di,PD,EMP1,EMP2,N,nb,SWFAC1,SWFAC2,PT,
     &             dN,p1, sla, dLAI)

        PRINT *, dLAI

        END PROGRAM MAIN


	PROGRAM FractalAnalysis
	!  Purpose:
	!    Calculating the fractal dimension
	!	 Step1: Get the length of the curve,L(m,k)
	!		m:initial time
	!		k:interval time
	!	  L(m,k)=sum(i=1,[(N-m)/k],|X(m+i*k)-X(m+(i-1)*k)|/k)
	!
	!    Step2: Get the average of L(m,k)& its Standard_dev
	!       ave_Lmk=sum(m=1,k,L(m,k))/k
	!       std_dev_Lmk=sqrt(k*L(m,k)**2-sum(L(m,k))**2))/(k*(k-1))
	!
	!  References:
	!	1.Higuchi,T.,1988.Approach to an irregular time
	!	   series on the basis of fractal theory.
	!	   Physica D 31.277-283
	!	2.Burlaga,L.F., Klein,L.W.,1986.Fractal structure of
	!	   the interplanetary magnetic field. J.Geophys.Res.91,374-350
	!	3.Gotoh,K.,Hayakawa,M.,Smirnova,N.A.,etal.2004. Fractal
	!	   analysis of seimogenic ULF emissions. Physis and Chemistry of
	!	   the Earth.29,419-424

	!  Record of revisions:
	!	Date	Programmer	Description of change
	!	====	==========	=====================
	! 2012/1/5    Q.Wang		Original code
	! 2012/1/8	  Q.Wang		Revised
	! 2012/1/9	  Q.Wang		Revised
	! 01/14/12    Q.Wang        Revised

    USE higuchi1988_type
    USE higuchi1988_subs
    use dflib

  	IMPLICIT NONE

    !> for DFA
	CHARACTER(len=30)::filename,lmk
	CHARACTER(len=4)::nof  !No. of file
	INTEGER(I4B)::nf       !No. of file
	REAL(DP),SAVE,ALLOCATABLE,DIMENSION(:) :: x
    REAL(DP),SAVE,allocatable,DIMENSION(:) :: section1year
    integer,parameter:: Nsubsec=180
	INTEGER(I1B)::fileindex
	INTEGER(I4B)::i, j, Nsec!Loop Index
	REAL(DP)::slope
	REAL(DP)::rcoef
	INTEGER(I1B)::status

    !> for cmd.exe
    character(len=255) :: cmd
    logical :: res

	!> input file's name
    WRITE(*,1)
1   FORMAT("Please Enter Other File's filename: ",$)
    READ(*,*)filename
    !filename='JIHminSr160'

	!  Open a file to output everyday's slope
	OPEN(100,FILE=trim(filename)//'slopes'//num2str(Nsubsec)//'.txt',STATUS='REPLACE',ACTION='WRITE')

	  !  Open File & Read data
	  CALL check_in(filename,x,status)

	  IF(ALLOCATED(x))THEN
          allocate(section1year(Nsubsec))
          Nsec=floor((size(x)-size(section1year)+10)/10.0)
         write(*,*)'Total section: ', Nsec
          do i=1,floor((size(x)-size(section1year)+10)/10.0)

              section1year(1:Nsubsec) = x(1 + (i-1)*10 : NsubSec + (i-1)*10 )

              !>> output subsection's data into files
              open(90,file=trim(filename)//'sec'//num2strN(i,len_trim(num2str(Nsec)))//'.dat',status='replace',action='write')
                    do j=1,Nsubsec
                        write(90,*)section1year(j)
                    enddo
              close(90)
              !> mkdir subdataBJIminSr160
              cmd='mkdir subdata_'//trim(filename)//num2str(Nsubsec)
              res = systemqq(cmd)
              !> move LMKBJIminSr160section??? into LMK_BJIminSr160
              cmd='move '//trim(filename)//'sec*.dat '//'subdata_'//trim(filename)//num2str(Nsubsec)
              res = systemqq(cmd)

              !>> DFA process
              CALL higuchi1988_v5(trim(filename)//'section'//num2str(i),section1year,lmk,slope,rcoef,status)
              WRITE(*,*)'STATUS=',status
              WRITE(100,10)ABS(slope),abs(rcoef)
10            FORMAT(1X,2F16.5)

              !> write xTickDays file for GMT5 plotting
              !if(mod(i,9)==0) write(10,*)i, 'a', (i-1)*10+1

          enddo
          deallocate(section1year)
          close(100)

          IF(status/=0)STOP

      ELSE
          WRITE(*,*)'Sub chek_in: the array is not allocated.'
      ENDIF

      !> mkdir LMK_BJIminSr160
      cmd='mkdir LMK_'//trim(filename)//num2str(Nsubsec)
      res = systemqq(cmd)
      !> move LMKBJIminSr160section??? into LMK_BJIminSr160
      cmd='move LMK'//trim(filename)//'section* '//'LMK_'//trim(filename)//num2str(Nsubsec)
      res = systemqq(cmd)

	END PROGRAM FractalAnalysis


      function atri(at1,at2,at3,at4i)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this function generates a random number from a triangular distribution
!!    given X axis points at start, end, and peak Y value

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    at1         |none          |lower limit for distribution
!!    at2         |none          |monthly mean for distribution
!!    at3         |none          |upper limit for distribution
!!    at4i        |none          |random number seed
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    atri        |none          |daily value generated for distribution
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    amn         |              |
!!    b1          |              |
!!    b2          |              |
!!    rn          |none          |random number between 0.0 and 1.0
!!    u3          |              |
!!    x1          |              |
!!    xx          |              |
!!    y           |              |
!!    yy          |              |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sqrt
!!    SWAT: Aunif

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real, intent (in) :: at1, at2, at3
      integer, intent (in out) :: at4i
      real :: u3, rn, y, b1, b2, x1, xx, yy, amn
      real :: atri

      u3 = 0.
      rn = 0.
      y = 0.
      b1 = 0.
      b2 = 0.
      x1 = 0.
      xx = 0.
      yy = 0.
      amn = 0.

      u3 = at2 - at1
      rn = Aunif(at4i)
      y = 2.0 / (at3 - at1)
      b2 = at3 - at2
      b1 = rn / y
      x1 = y * u3 / 2.0

      if (rn <= x1) then
        xx = 2.0 * b1 * u3
        if (xx <= 0.) then
          yy = 0.
        else
          yy = Sqrt(xx)
        end if
        atri = yy + at1
      else
        xx = b2 * b2 - 2.0 * b2 * (b1 - 0.5 * u3)
        if (xx <= 0.) then
          yy = 0.
        else
          yy = Sqrt(xx)
        end if
        atri = at3 - yy
      end if

      amn = (at3 + at2 + at1) / 3.0
      atri = atri * at2 / amn

      if (atri >= 1.0) atri = 0.99
      if (atri <= 0.0) atri = 0.001

      return
      end


!     =====================================================
    subroutine qinit(maxmx,maxmy,num_eqn,num_ghost,mx,my,xlower,ylower, &
    dx,dy,q,num_aux,aux,Rsphere)
!     =====================================================

!      # Set initial conditions for q.

!      # -------4-Rossby-Haurwitz wave-----------------------

    implicit double precision (a-h,o-z)
    dimension q(num_eqn, 1-num_ghost:maxmx+num_ghost, 1-num_ghost:maxmy+num_ghost)
    dimension aux(num_aux, 1-num_ghost:maxmx+num_ghost, 1-num_ghost:maxmy+num_ghost)
    double precision :: Uin(3),Uout(3)
    double precision :: K
!f2py integer intent(in) maxmx
!f2py integer intent(in) maxmy
!f2py integer optional,intent(in) num_eqn
!f2py integer intent(in) num_ghost
!f2py integer intent(in) mx
!f2py integer intent(in) my
!f2py double precision intent(in) xlower
!f2py double precision intent(in) ylower
!f2py double precision intent(in) dx
!f2py double precision intent(in) dy
!f2py intent(in,out) q
!f2py integer optional, intent(in)  num_aux
!f2py intent(in) aux
!f2py double precision intent(in) Rsphere

    pi = 4.d0*datan(1.d0)

!      # Parameters
    a = 6.37122d6
    K = 7.848d-6
    Omega = 7.292d-5
    G = 9.80616d0
    t0 = 86400.d0
    h0 = 8.d3
    R = 4.d0

    do 20 i=1,mx
        xc = xlower + (i-0.5d0)*dx
        do 20 j=1,my
            yc = ylower + (j-0.5d0)*dy
            call mapc2p(xc,yc,xp,yp,zp,Rsphere)
        !            # compute longitude theta from positive x axis:
            rad = dmax1(dsqrt(xp**2 + yp**2),1.d-6)

            if(xp > 0.d0 .AND. yp > 0.d0) then
                theta = dasin(yp/rad)
            elseif(xp < 0.d0 .AND. yp > 0.d0) then
                theta = pi - dasin(yp/rad)
            elseif(xp < 0.d0 .AND. yp < 0.d0) then
                theta = -pi+dasin(-yp/rad)
            elseif(xp > 0.d0 .AND. yp < 0.d0) then
                theta = -dasin(-yp/rad)
            endif

        !            # compute phi, at north pole: pi/2 at south pool: -pi/2
            if (zp > 0.d0) then
                phi =  dasin(zp/Rsphere)
            else
                phi = -dasin(-zp/Rsphere)
            endif

            xp = theta
            yp = phi

            bigA = 0.5d0*K*(2.d0*Omega+K)*dcos(yp)**2.d0 + &
            0.25d0*K*K*dcos(yp)**(2.d0*R)*( &
            (1.d0*R+1.d0)*dcos(yp)**2.d0 &
            +(2.d0*R*R - 1.d0*R - 2.d0) &
            - 2.d0*R*R*(dcos(yp))**(-2.d0))
            bigB = (2.d0*(Omega+K)*K)/((1.d0*R+1.d0)*(1.d0*R+2.d0)) &
            *dcos(yp)**R*( (1.d0*R*R + 2.d0*R + 2.d0) &
            - (1.d0*R+1.d0)**(2)*dcos(yp)**2 )
            bigC = 0.25d0*K*K*dcos(yp)**(2*R)*( (1.d0*R + 1.d0)* &
            dcos(yp)**2 - (1.d0*R + 2.d0))

        !            # longitude (angular) velocity component
            Uin(1) = (K*dcos(yp)+K*dcos(yp)**(R-1.)*( R*dsin(yp)**2. &
            - dcos(yp)**2. )*dcos(R*xp))*t0

        !            # latitude (angular) velocity component
            Uin(2) = (-K*R*dcos(yp)**(R-1.)*dsin(yp)*dsin(R*xp))*t0

        !            # radial velocity component
            Uin(3) = 0.d0

        !            # calculate velocity vetor in cartesian coordinates
            Uout(1) = (-dsin(xp)*Uin(1)-dsin(yp)*dcos(xp)*Uin(2))
            Uout(2) = (dcos(xp)*Uin(1)-dsin(yp)*dsin(xp)*Uin(2))
            Uout(3) = dcos(yp)*Uin(2)

        !            # set the clawpack initial values:
            q(1,i,j) =  h0/a + (a/G)*( bigA + bigB*dcos(R*xp) &
            + bigC*dcos(2.d0*R*xp))
            q(2,i,j) = q(1,i,j)*Uout(1)
            q(3,i,j) = q(1,i,j)*Uout(2)
            q(4,i,j) = q(1,i,j)*Uout(3)

    20 END DO

    return
    end subroutine qinit


program matMulProduct
   use orthogonalization
   real(rk), allocatable :: A(:, :), Q(:, :), R(:, :), E(:, :)
   integer :: i, j, n, p, ncsf
   n = 2
   p = 3
   allocate(A(n, p))
   A(:, 1) = (/2,-1/)
   A(:, 2) = (/-2, 1/)
   A(:, 3) = (/3, 0/)
  ! call gs(A, Q, R, E, n, p, ncsf)
   call gs_modify(A, n, p)

   !write(*, *) 'Q = '
   !do i = 1, n
   !    write(*, *) Q(i, :)
   !enddo

  ! write(*, *) 'R = '
  ! do i = 1, p
  !     write(*, *) R(i, :)
  ! enddo

!   write(*, *) 'E = '
!   do i = 1, n
!       write(*, *) E(i, 1:ncsf)
!   enddo

end program matMulProduct


C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE CMGNBN TO SOLVE
C     THE EQUATION
C
C     (1+X)**2*(D/DX)(DU/DX) - 2(1+X)(DU/DX) + (D/DY)(DU/DY)
C
C             - SQRT(-1)*U = (3 - SQRT(-1))*(1+X)**4*SIN(Y)         (1)
C
C     ON THE RECTANGLE 0 .LT. X .LT. 1 AND -PI .LT. Y .LT. PI
C     WITH THE BOUNDARY CONDITIONS
C
C     (DU/DX)(0,Y) = 4SIN(Y)                               (2)
C                                -PI .LE. Y .LE. PI
C     U(1,Y) = 16SIN(Y)                                    (3)
C
C     AND WITH U PERIODIC IN Y USING FINITE DIFFERENCES ON A
C     GRID WITH DELTAX (= DX) = 1/20 AND DELTAY (= DY) = PI/20.
C        TO SET UP THE FINITE DIFFERENCE EQUATIONS WE DEFINE
C     THE GRID POINTS
C
C     X(I) = (I-1)DX            I=1,2,...,21
C
C     Y(J) = -PI + (J-1)DY      J=1,2,...,41
C
C     AND LET V(I,J) BE AN APPROXIMATION TO U(X(I),Y(J)).
C     NUMBERING THE GRID POINTS IN THIS FASHION GIVES THE SET
C     OF UNKNOWNS AS V(I,J) FOR I=1,2,...,20 AND J=1,2,...,40.
C     HENCE, IN THE PROGRAM M = 20 AND N = 40.  AT THE INTERIOR
C     GRID POINT (X(I),Y(J)), WE REPLACE ALL DERIVATIVES IN
C     EQUATION (1) BY SECOND ORDER CENTRAL FINITE DIFFERENCES,
C     MULTIPLY BY DY**2, AND COLLECT COEFFICIENTS OF V(I,J) TO
C     GET THE FINITE DIFFERENCE EQUATION
C
C     A(I)V(I-1,J) + B(I)V(I,J) + C(I)V(I+1,J)
C
C     + V(I,J-1) - 2V(I,J) + V(I,J+1) = F(I,J)            (4)
C
C     WHERE S = (DY/DX)**2, AND FOR I=2,3,...,19
C
C     A(I) = (1+X(I))**2*S + (1+X(I))*S*DX
C
C     B(I) = -2(1+X(I))**2*S - SQRT(-1)*DY**2
C
C     C(I) = (1+X(I))**2*S - (1+X(I))*S*DX
C
C     F(I,J) = (3 - SQRT(-1))*(1+X(I))**4*DY**2*SIN(Y(J))
C              FOR J=1,2,...,40.
C
C        TO OBTAIN EQUATIONS FOR I = 1, WE REPLACE THE
C     DERIVATIVE IN EQUATION (2) BY A SECOND ORDER CENTRAL
C     FINITE DIFFERENCE APPROXIMATION, USE THIS EQUATION TO
C     ELIMINATE THE VIRTUAL UNKNOWN V(0,J) IN EQUATION (4)
C     AND ARRIVE AT THE EQUATION
C
C     B(1)V(1,J) + C(1)V(2,J) + V(1,J-1) - 2V(1,J) + V(1,J+1)
C
C                       = F(1,J)
C
C     WHERE
C
C     B(1) = -2S - SQRT(-1)*DY**2 , C(1) = 2S
C
C     F(1,J) = (11-SQRT(-1)+8/DX)*DY**2*SIN(Y(J)),  J=1,2,...,40.
C
C     FOR COMPLETENESS, WE SET A(1) = 0.
C        TO OBTAIN EQUATIONS FOR I = 20, WE INCORPORATE
C     EQUATION (3) INTO EQUATION (4) BY SETTING
C
C     V(21,J) = 16SIN(Y(J))
C
C     AND ARRIVE AT THE EQUATION
C
C     A(20)V(19,J) + B(20)V(20,J)
C
C     + V(20,J-1) - 2V(20,J) + V(20,J+1) = F(20,J)
C
C     WHERE
C
C     A(20) = (1+X(20))**2*S + (1+X(20))*S*DX
C
C     B(20) = -2*(1+X(20))**2*S - SQRT(-1)*DY**2
C
C     F(20,J) = ((3-SQRT(-1))*(1+X(20))**4*DY**2 - 16(1+X(20))**2*S
C                + 16(1+X(20))*S*DX)*SIN(Y(J))
C
C                    FOR J=1,2,...,40.
C
C     FOR COMPLETENESS, WE SET C(20) = 0.  HENCE, IN THE
C     PROGRAM MPEROD = 1.
C        THE PERIODICITY CONDITION ON U GIVES THE CONDITIONS
C
C     V(I,0) = V(I,40) AND V(I,41) = V(I,1) FOR I=1,2,...,20.
C
C     HENCE, IN THE PROGRAM NPEROD = 0.
C
C          THE EXACT SOLUTION TO THIS PROBLEM IS
C
C                  U(X,Y) = (1+X)**4*SIN(Y) .
C
      COMPLEX         F          ,A          ,B          ,C          ,W
      DIMENSION       F(22,40)   ,A(20)      ,B(20)      ,C(20)      ,
     1                X(21)      ,Y(41)      ,W(380)
C
C     FROM THE DIMENSION STATEMENT WE GET THAT IDIMF = 22 AND THAT W
C     HAS BEEN DIMENSIONED
C
C     4N + (10+INT(LOG2(N)))M = 4*20 + (10+5)*20 = 380 .
C
      IDIMF = 22
      M = 20
      MP1 = M+1
      MPEROD = 1
      DX = 0.05
      N = 40
      NPEROD = 0
      PI = PIMACH(DUM)
      DY = PI/20.
C
C     GENERATE GRID POINTS FOR LATER USE.
C
      DO 101 I=1,MP1
         X(I) = FLOAT(I-1)*DX
  101 CONTINUE
      DO 102 J=1,N
         Y(J) = -PI+FLOAT(J-1)*DY
  102 CONTINUE
C
C     GENERATE COEFFICIENTS.
C
      S = (DY/DX)**2
      DO 103 I=2,19
         T = 1.+X(I)
         TSQ = T**2
         A(I) = CMPLX((TSQ+T*DX)*S,0.)
         B(I) = -2.*TSQ*S-(0.,1.)*DY**2
         C(I) = CMPLX((TSQ-T*DX)*S,0.)
  103 CONTINUE
      A(1) = (0.,0.)
      B(1) = -2.*S-(0.,1.)*DY**2
      C(1) = CMPLX(2.*S,0.)
      B(20) = -2.*S*(1.+X(20))**2-(0.,1.)*DY**2
      A(20) = CMPLX(S*(1.+X(20))**2+(1.+X(20))*DX*S,0.)
      C(20) = (0.,0.)
C
C     GENERATE RIGHT SIDE.
C
      DO 105 I=2,19
         DO 104 J=1,N
            F(I,J) = (3.,-1.)*(1.+X(I))**4*DY**2*SIN(Y(J))
  104    CONTINUE
  105 CONTINUE
      T = 1.+X(20)
      TSQ = T**2
      T4 = TSQ**2
      DO 106 J=1,N
         F(1,J) = ((11.,-1.)+8./DX)*DY**2*SIN(Y(J))
         F(20,J) = ((3.,-1.)*T4*DY**2-16.*TSQ*S+16.*T*S*DX)*SIN(Y(J))
  106 CONTINUE
      CALL CMGNBN (NPEROD,N,MPEROD,M,A,B,C,IDIMF,F,IERROR,W)
C
C     COMPUTE DISCRETIAZATION ERROR.  THE EXACT SOLUTION IS
C
C            U(X,Y) = (1+X)**4*SIN(Y) .
C
      ERR = 0.
      DO 108 I=1,M
         DO 107 J=1,N
            T = CABS(F(I,J)-(1.+X(I))**4*SIN(Y(J)))
            IF (T .GT. ERR) ERR = T
  107    CONTINUE
  108 CONTINUE
      T = REAL(W(1))
      PRINT 1001 , IERROR,ERR,T
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE CMGNBN EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 9.16200E-03/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 380//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,F4.0)
C
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                              !
! pcreo - Point Configuration Riesz Energy Optimizer                           !
!                                                                              !
! This program generates point configurations on (hyper)surfaces embedded in   !
! Euclidean space and optimizes their Riesz s-energy by gradient descent.      !
! For large values of s, this produces evenly distributed point                !
! configurations, while for small values of s, the points tend to cluster      !
! around the extremeties of the surface.                                       !
!                                                                              !
! The surface on which to generate point configurations is specified by giving !
! a function f for which the desired surface is the level set f(x) = 0. The    !
! gradient of f is also required. These functions should be defined in the     !
! surface_parameters module below.                                             !
!                                                                              !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module constants !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                              !
! The constants module contains basic constants (e.g. pi, e, number kind IDs)  !
! used throughout the rest of the program.                                     !
!                                                                              !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    integer, parameter :: sp = selected_real_kind(6, 37)    ! IEEE single prec.
    integer, parameter :: dp = selected_real_kind(15, 307)  ! IEEE double prec.
    integer, parameter :: qp = selected_real_kind(33, 4931) ! IEEE quad prec.

    integer, parameter :: rk = dp ! Real kind. Edit this line to change
    ! the floating-point precision used in the rest of the program.

    real(rk), parameter :: two_pi = 6.2831853071795864769d0

end module constants

module input_parameters !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                              !
! The input_parameters module contains subroutines for retrieving and parsing  !
! command-line arguments. These arguments are stored in protected variables,   !
! so that they cannot accidentally be modified in other modules.               !
!                                                                              !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    use constants
    implicit none

    integer, protected :: num_points, max_iters, output_freq
    real(rk), protected :: s ! Riesz potential power parameter

contains

    integer function get_integer_argument(n) result (ans)
        integer, intent(in) :: n

        integer :: cmd_len
        character(len=:), allocatable :: cmd_arg

        call get_command_argument(n, length=cmd_len)
        allocate(character(len=cmd_len) :: cmd_arg)
        call get_command_argument(n, value=cmd_arg)
        read(cmd_arg,*) ans
        deallocate(cmd_arg)
    end function get_integer_argument

    real(rk) function get_real_argument(n) result (ans)
        integer, intent(in) :: n

        integer :: cmd_len
        character(len=:), allocatable :: cmd_arg

        call get_command_argument(n, length=cmd_len)
        allocate(character(len=cmd_len) :: cmd_arg)
        call get_command_argument(n, value=cmd_arg)
        read(cmd_arg,*) ans
        deallocate(cmd_arg)
    end function get_real_argument

    subroutine get_input_parameters
        integer :: cmd_count

        cmd_count = command_argument_count()
        if (cmd_count < 3 .or. cmd_count > 4) then
            write(*,*) "Usage: pcreo <s> <num_points>&
                                & <output_frequency> [max_iters]"
            stop
        end if

        s = get_real_argument(1)
        num_points = get_integer_argument(2)
        output_freq = get_integer_argument(3)

        if (cmd_count == 3) then
            max_iters = -1 ! if not provided, then iterate forever
        else
            max_iters = get_integer_argument(4)
        end if
    end subroutine get_input_parameters

end module input_parameters

module surface_parameters !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                              !
! The surface_parameters module contains functions and subroutines specifying  !
! the (hyper)surface on which to generate and optimize point configurations.   !
! In particular, the surface used is the zero locus of the constraint_value    !
! function.                                                                    !
!                                                                              !
! A constraint_gradient subroutine which calculates the gradient of the        !
! constraint_value function must be provided. A constraint_value_gradient      !
! subroutine, which calculates both the value and the gradient of the          !
! constraint function simultaneously, is also required. The reason is that in  !
! some cases, it may be faster to compute these quantities together (e.g. if   !
! they share common sub-expressions that only need to be computed once).       !
!                                                                              !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    use constants
    implicit none

    ! Dimension of the surface and the ambient space in which it is embedded.
    ! We require srf_dim == amb_dim - 1. This may change in a later version.
    integer, parameter :: srf_dim = 2
    integer, parameter :: amb_dim = 3

    ! Bounding box for the surface. Used when generating random points.
    real(rk), parameter :: srf_min(3) = [-2.0d0, -2.0d0, -2.0d0]
    real(rk), parameter :: srf_max(3) = [+2.0d0, +2.0d0, +2.0d0]

contains

    pure real(rk) function constraint_value(x)
        real(rk), intent(in) :: x(amb_dim)

        real(rk) :: x2, y2, z2, r2, t, u, v

        x2 = x(1) * x(1)
        y2 = x(2) * x(2)
        z2 = x(3) * x(3)
        r2 = x2 + y2
        t = 1 - z2
        u = y2 - 3*x2
        v = 1 + 2*x(2)*u - 9*z2

        constraint_value = r2*r2 + v*t
    end function constraint_value

    pure subroutine constraint_gradient(x, g)
        real(rk), intent(in) :: x(amb_dim)
        real(rk), intent(out) :: g(amb_dim)

        real(rk) :: x2, y2, z2, r2, t, u, v

        x2 = x(1) * x(1)
        y2 = x(2) * x(2)
        z2 = x(3) * x(3)
        r2 = x2 + y2
        t = 1 - z2
        u = y2 - 3*x2
        v = 1 + 2*u*x(2) - 9*z2

        g(1) = 4*x(1)*(r2 - 3*x(2)*t)
        g(2) = 4*x(2)*r2 - 6*t*(x2 - y2)
        g(3) = -2*x(3)*(v + 9*t)
    end subroutine constraint_gradient

    pure subroutine constraint_value_gradient(x, c, g)
        real(rk), intent(in) :: x(amb_dim)
        real(rk), intent(out) :: c, g(amb_dim)

        real(rk) :: x2, y2, z2, r2, t, u, v

        x2 = x(1) * x(1)
        y2 = x(2) * x(2)
        z2 = x(3) * x(3)
        r2 = x2 + y2
        t = 1 - z2
        u = y2 - 3*x2
        v = 1 + 2*u*x(2) - 9*z2

        c = r2*r2 + v*t
        g(1) = 4*x(1)*(r2 - 3*x(2)*t)
        g(2) = 4*x(2)*r2 - 6*t*(x2 - y2)
        g(3) = -2*x(3)*(v + 9*t)
    end subroutine constraint_value_gradient

end module surface_parameters

module constrained_energy_optimization

    use ieee_arithmetic
    use surface_parameters
    implicit none

contains

    pure subroutine constrain(x, c)
        real(rk), intent(inout) :: x(amb_dim)
        real(rk), intent(out) :: c

        real(rk) :: c_old, c_new, alpha
        real(rk) :: g(amb_dim) ! constraint gradient at original point
        real(rk) :: h(amb_dim) ! constraint gradient at most recent point
        real(rk) :: y(amb_dim) ! last known good point
        real(rk) :: z(amb_dim) ! most recent point

        y = x
        call constraint_value_gradient(x, c_old, g)
        alpha = -c_old / dot_product(g, g)
        do
            z = x + alpha * g
            call constraint_value_gradient(z, c_new, h)
            if (ieee_is_finite(c_new) .and. ieee_is_finite(c_old) .and. &
                & abs(c_new) < abs(c_old)) then
                alpha = alpha - c_new / dot_product(g, h)
                c_old = c_new
                y = z
            else ! Improvement has stopped. End Newton iteration.
                exit
            end if
        end do
        x = y
        c = c_old
    end subroutine constrain

    pure subroutine constrain_points(points, c_values)
        real(rk), intent(inout) :: points(:,:)
        real(rk), intent(out) :: c_values(:)

        integer :: i

        do i = 1, size(points, 2)
            call constrain(points(:,i), c_values(i))
        end do
    end subroutine constrain_points

    subroutine random_surface_point(x, c)
        real(rk), intent(out) :: x(amb_dim), c

        integer :: i

        do
            do i = 1, amb_dim
                call random_number(x(i))
                x(i) = srf_min(i) + (srf_max(i) - srf_min(i)) * x(i)
            end do
            call constrain(x, c)
            if (abs(constraint_value(x)) < 10*epsilon(x)) return
        end do
    end subroutine random_surface_point

    subroutine random_surface_points(points, c_values)
        real(rk), intent(out) :: points(:,:), c_values(:)

        integer :: i

        do i = 1, size(points, 2)
            call random_surface_point(points(:,i), c_values(i))
        end do
    end subroutine random_surface_points

    pure subroutine tangential_component(x, p)
        real(rk), intent(in) :: x(amb_dim)
        real(rk), intent(inout) :: p(amb_dim)

        real(rk) :: g(amb_dim), alpha

        call constraint_gradient(x, g)
        alpha = dot_product(p, g) / dot_product(g, g)
        p = p - alpha * g
    end subroutine tangential_component

    pure real(rk) function riesz_energy(s, points)
        real(rk), intent(in) :: s, points(:,:)

        integer :: i, j

        riesz_energy = 0
        do j = 1, size(points, 2)
            do i = 1, j - 1
                riesz_energy = riesz_energy + &
                        & norm2(points(:,i) - points(:,j))**(-s)
            end do
        end do
    end function riesz_energy

    pure subroutine riesz_energy_gradient(s, points, ener, grad)
        real(rk), intent(in) :: s, points(:,:)
        real(rk), intent(out) :: ener, grad(:,:)

        real(rk) :: displ(amb_dim), dist_sq, term
        integer :: i, j

        ener = 0
        do j = 1, size(points, 2)
            grad(:,j) = 0
            do i = 1, j - 1
                displ = points(:,i) - points(:,j)
                dist_sq = dot_product(displ, displ)
                term = dist_sq**(-0.5d0 * s)
                ener = ener + term
                term = s * term / dist_sq
                grad(:,j) = grad(:,j) + term * displ
            end do
            do i = j + 1, size(points, 2)
                displ = points(:,i) - points(:,j)
                term = s * norm2(displ)**(-s - 2.0d0)
                grad(:,j) = grad(:,j) + term * displ
            end do
            call tangential_component(points(:,j), grad(:,j))
        end do
    end subroutine riesz_energy_gradient

!~     pure real(rk) function step_norm(step)
!~         real(rk), intent(in) :: step(:,:)

!~         real(rk) :: norm_sq
!~         integer :: i

!~         step_norm = 0
!~         do i = 1, num_points
!~             norm_sq = step(1,i)*step(1,i) + step(2,i)*step(2,i) + step(3,i)*step(3,i)
!~             if (norm_sq > step_norm) step_norm = norm_sq
!~         end do
!~         step_norm = sqrt(step_norm)
!~     end function step_norm

    pure real(rk) function step_norm(step)
        real(rk), intent(in) :: step(:,:)

        step_norm = norm2(step)
    end function step_norm

end module constrained_energy_optimization

program test

    use input_parameters
    use constrained_energy_optimization
    implicit none

    real(rk), allocatable :: points_old(:,:)
    real(rk), allocatable :: points_new(:,:)
    real(rk), allocatable :: grad_step(:,:)
    real(rk), allocatable :: c_values(:)

    real(rk) :: ener_old, ener_new, step_size, grad_norm, constraint_err
    integer :: u, num_good_iters, num_bad_iters
    character(len=34) :: fname

    call init_random_seed
    call print_welcome_message
    call get_input_parameters
    call print_input_parameters
    write(*,*)

    allocate(points_old(amb_dim, num_points))
    allocate(points_new(amb_dim, num_points))
    allocate(grad_step(amb_dim, num_points))
    allocate(c_values(num_points))

    write(*,*) "Generating random initial point configuration..."
    call random_surface_points(points_old, c_values)
    call riesz_energy_gradient(s, points_old, ener_old, grad_step)
    write(*,*) "Point configuration initialized."
    write(*,*)
    write(*,*) "# Good steps| # Bad steps | Riesz s-energy         &
            & | Gradient norm           | Step size              &
            & | Constraint error"
    write(*,*) "------------+-------------+------------------------&
            &-+-------------------------+------------------------&
            &-+-------------------------"

    step_size = 1
    num_good_iters = 0
    num_bad_iters = 0
    do
        grad_norm = step_norm(grad_step)
        grad_step = step_size * grad_step / grad_norm
        points_new = points_old - grad_step
        call constrain_points(points_new, c_values)
        constraint_err = maxval(abs(c_values))
        if (constraint_err > 1.0d-10) then
            step_size = 1.0d-2 * step_size
            num_bad_iters = num_bad_iters + 1
            cycle
        end if
        call riesz_energy_gradient(s, points_new, ener_new, grad_step)
        if (ener_new < ener_old) then
            num_good_iters = num_good_iters + 1
            write(*,*) num_good_iters, "|", num_bad_iters, "|", &
                    & ener_new, "|", grad_norm, "|", step_size, "|", &
                    & constraint_err
            if (mod(num_good_iters, output_freq) == 0 .or. &
                    & num_good_iters == max_iters) then
                write(fname,"(a,i10.10,a)") "point_configuration_", &
                        & num_good_iters, ".txt"
                open(file=fname, newunit=u)
                write(u,*) points_new
                close(u)
            end if
            if (num_good_iters == max_iters) exit
            points_old = points_new
            ener_old = ener_new
        else
            num_bad_iters = num_bad_iters + 1
            step_size = 0.5d0 * step_size
        end if
    end do

contains

    subroutine init_random_seed
        integer :: i, n, clock
        integer, allocatable :: seed(:)

        call random_seed(size=n)
        allocate(seed(n))
        call system_clock(count=clock)
        seed = clock + 37 * (/ (i, i = 1,n) /)
        call random_seed(put=seed)
        deallocate(seed)
    end subroutine init_random_seed

    subroutine print_input_parameters
        write(*,*) "Value of s (Riesz potential power parameter): ", s
        write(*,*) "Number of points: ", num_points
        write(*,*) "Output frequency: every ", output_freq, " iterations"

        if (max_iters == -1) then
            write(*,*) "Maximum number of iterations not specified.&
                        & Iterating indefinitely."
        else
            write(*,*) "Maximum number of iterations: ", max_iters
        end if
    end subroutine print_input_parameters

    subroutine print_welcome_message
        write(*,*) "  _____   _____                             "
        write(*,*) " |  __ \ / ____|                Version 1.0 "
        write(*,*) " | |__) | |     _ __ ___  ___               "
        write(*,*) " |  ___/| |    | '__/ _ \/ _ \  David Zhang "
        write(*,*) " | |    | |____| | |  __/ (_) |             "
        write(*,*) " |_|     \_____|_|  \___|\___/  TDT Surface "
        write(*,*) "                                            "
    end subroutine print_welcome_message

end program test


MODULE vector_module
!
!  Purpose:
!    To define the derived data type for 2D vectors,
!    plus addition and subtraction operations.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     12/04/06    S. J. Chapman        Original code
! 1.  12/22/06    S. J. Chapman        Use bound procedures
!
IMPLICIT NONE

! Declare type vector
TYPE :: vector
   REAL :: x                         ! X value
   REAL :: y                         ! Y value
CONTAINS
   PROCEDURE,PASS :: vector_add
   PROCEDURE,PASS :: vector_sub
END TYPE vector

! Add procedures
CONTAINS

   TYPE (vector) FUNCTION vector_add ( this, v2 )
   !
   !  Purpose:
   !    To add two vectors.
   !
   !  Record of revisions:
   !       Date       Programmer          Description of change
   !       ====       ==========          =====================
   !     12/04/06    S. J. Chapman        Original code
   ! 1.  12/22/06    S. J. Chapman        Use bound procedures
   !
   IMPLICIT NONE

   ! Data dictionary: declare calling parameter types & definitions
   CLASS(vector),INTENT(IN) :: this         ! First vector
   CLASS(vector),INTENT(IN) :: v2           ! Second vector

   ! Add the vectors
   vector_add%x = this%x + v2%x
   vector_add%y = this%y + v2%y

   END FUNCTION vector_add

   TYPE (vector) FUNCTION vector_sub ( this, v2 )
   !
   !  Purpose:
   !    To subtract two vectors.
   !
   !  Record of revisions:
   !       Date       Programmer          Description of change
   !       ====       ==========          =====================
   !     12/04/06    S. J. Chapman        Original code
   ! 1.  12/22/06    S. J. Chapman        Use bound procedures
   !
   IMPLICIT NONE

   ! Data dictionary: declare calling parameter types & definitions
   CLASS(vector),INTENT(IN) :: this         ! First vector
   CLASS(vector),INTENT(IN) :: v2           ! Second vector

   ! Add the points
   vector_sub%x = this%x - v2%x
   vector_sub%y = this%y - v2%y

   END FUNCTION vector_sub

END MODULE vector_module


SUBROUTINE rod_mm(mm,length)
!
! This subroutine forms the consistent mass matrix of a 1-d "rod" element.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in)::length
 REAL(iwp),intent(out)::mm(:,:)
 REAL(iwp)::one=1.0_iwp,d3=3.0_iwp,d6=6.0_iwp
 mm(1,1)=one/d3
 mm(1,2)=one/d6
 mm(2,1)=one/d6
 mm(2,2)=one/d3
 mm=mm*length
RETURN
END SUBROUTINE rod_mm


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     THIS PROGRAM ILLUSTRATES THE USE OF THE SUBROUTINE POIS3D TO SOLVE
C     THE EQUATION
C
C     (D/DX)(DU/DX) + (D/DY)(DU/DY) + (1+Z)**2*(D/DZ)(DU/DZ)
C
C     - 2*(1+Z)*(DU/DZ) = 2*SIN(X)*SIN(Y)*(1+Z)**4                   (1)
C
C     ON THE PARALLELEPIPED -PI .LT. X .LT. PI, -PI .LT. Y .LT. PI,
C     0 .LT. Z .LT. 1 WITH BOUNDARY CONDITIONS
C
C     U PERIODIC IN X
C
C     U PERIODIC IN Y
C
C     (DU/DZ)(X,Y,0) = 4*SIN(X)*SIN(Y)    -PI .LT. X,Y .LT. PI       (2)
C
C     U(X,Y,1) = 16*SIN(X)*SIN(Y)         -PI .LT. X,Y .LT. PI       (3)
C
C     USING A FINITE DIFFERENCE GRID WITH DELTAX (= DX) = 2*PI/30 ,
C     DELTAY (= DY) = 2*PI/30, AND DELTAZ (= DZ) = 1/10.
C         TO SET UP THE FINITE DIFFERENCE EQUATIONS WE DEFINE THE GRID
C     POINTS
C
C         X(I) = -PI + (I-1)*DX         I=1,2,...,31
C
C         Y(J) = -PI + (J-1)*DY         J=1,2,...,31
C
C         Z(K) = (K-1)*DZ               K=1,2,...,11
C
C     AND LET V(I,J,K) BE AN APPROXIMATION TO U(X(I),Y(J),Z(K)).
C     NUMBERING THE GRID POINTS IN THIS FASHION GIVES THE SET OF
C     UNKNOWNS AS V(I,J,K) FOR I=1,2,...,30, J=1,2,...,30, K=1,2,...,10.
C     HENCE, IN THE PROGRAM L=30, M = 30, AND N = 10.  AT THE INTERIOR
C     GRID POINT (X(I),Y(J),Z(K)), WE REPLACE ALL DERIVATIVES IN
C     EQUATION (1) BY SECOND ORDER CENTRAL FINITE DIFFERENCES AND
C     COLLECT COEFFICIENTS OF V(I,J,K) TO GET THE FINITE DIFFERENCE
C     EQUATION
C
C        (V(I-1,J,K) - 2V(I,J,K) + V(I+1,J,K))/DX**2
C
C      + (V(I,J-1,K) - 2V(I,J,K) + V(I,J+1,K))/DY**2
C
C      + A(K)V(I,J,K-1) + B(K)V(I,J,K) + C(K)V(I,J,K+1) = F(I,J,K)   (4)
C
C     WHERE FOR K=2,3,...,9
C
C     A(K) = (1+Z(K))**2/DZ**2 + (1+Z(K))/DZ
C
C     B(K) = -2(1+Z(K))**2/DZ**2
C
C     C(K) = (1+Z(K))**2/DZ**2 - (1+Z(K))/DZ
C
C     F(I,J,K) = 2SIN(X(I))*SIN(Y(J))*(1+Z(K))**4  FOR I,J=1,2,...,30.
C
C         TO OBTAIN EQUATIONS FOR K=1, WE REPLACE THE DERIVATIVE IN
C     EQUATION (2) BY A SECOND ORDER CENTRAL FINITE DIFFERENCE APPROX-
C     IMATION, USE THIS EQUATION TO ELIMINATE THE VIRTUAL UNKNOWN
C     V(I,J,0) IN EQUATION (4) AND ARRIVE AT THE EQUATION
C
C              (V(I-1,J,1) -2V(I,J,1) + V(I+1,J,1))/DX**2
C
C            + (V(I,J-1,1) -2V(I,J,1) + V(I,J+1,1))/DY**2
C
C            + B(1)V(I,J,1) + C(1)V(I,J,2) = F(I,J,1)
C
C     WHERE
C            B(1) = -C(1) = -2(1+Z(1))**2/DZ**2 = -2/DZ**2
C
C            F(I,J,1) = (10 + 8/DZ)SIN(X(I))*SIN(Y(J))
C
C            FOR I,J=1,2,...,30.  FOR COMPLETENESS WE SET A(1) = 0.
C
C         TO OBTAIN EQUATIONS FOR K=10, WE INCORPORATE EQUATION (3) INTO
C     EQUATION (4) BY SETTING
C
C            V(I,J,11) = U(X(I),Y(J),1) = 16SIN(X(I))*SIN(Y(J))
C
C     AND ARRIVE AT THE EQUATION
C
C              (V(I-1,J,10) - 2V(I,J,10) + V(I+1,J,10))/DX**2
C
C            + (V(I,J-1,10) - 2V(I,J,10) + V(I,J+1,10))/DY**2
C
C            + A(10)V(I,J,9) + B(10)V(I,J,10) = F(I,J,10)
C
C     WHERE
C
C            A(10) = (1+Z(10))**2/DZ**2 + (1+Z(10))/DZ
C
C            B(10) = -2(1+Z(10))**2/DZ**2
C
C            F(I,J,10) = 2SIN(X(I))*SIN(Y(J))*((1+Z(10))**4
C                        -8*((1+Z(10))**2/DZ**2 - (1+Z(10))/DZ))
C
C                        FOR I,J=1,2,...,30.
C
C     FOR COMPLETENESS, WE SET C(10) = 0.  HENCE, IN THE PROGRAM,
C     NPEROD = 1.
C         THE PERIODICITY CONDITIONS ON U GIVE THE CONDITIONS
C
C             V(0,J,K) = V(30,J,K) AND V(31,J,K) = V(1,J,K)
C                        FOR J=1,2,...,30 AND K=1,2,...,10,
C             AND
C             V(I,0,K) = V(I,30,K) AND V(I,31,K) = V(I,1,K)
C                        FOR I=1,2,...,30 AND K=1,2,...,10.
C
C     HENCE, IN THE PROGRAM LPEROD = MPEROD = 0.
C
      DIMENSION       F(32,33,10),A(10)      ,B(10)      ,C(10)      ,
     1                W(350)     ,X(30)      ,Y(30)      ,Z(10)
C
C     FROM THE DIMENSION STATEMENT WE GET THAT LDIMF = 32, MDIMF = 33,
C     AND NOTE THAT W HAS BEEN DIMENSIONED ACCORDING TO ITS DESCRIPTION.
C
      LDIMF = 32
      MDIMF = 33
      PI = PIMACH(DUM)
      LPEROD = 0
      L = 30
      DX = 2.*PI/FLOAT(L)
      C1 = 1./DX**2
      MPEROD = 0
      M = 30
      DY = 2.*PI/FLOAT(M)
      C2 = 1./DY**2
      NPEROD = 1
      N = 10
      DZ = 1./FLOAT(N)
      DZSQ = 1./DZ**2
C
C     GENERATE GRID POINTS FOR LATER USE.
C
      DO 101 I=1,L
         X(I) = -PI+FLOAT(I-1)*DX
  101 CONTINUE
      DO 102 J=1,M
         Y(J) = -PI+FLOAT(J-1)*DY
  102 CONTINUE
C
C     GENERATE COEFFICIENTS
C
      A(1) = 0.
      B(1) = -2.*DZSQ
      C(1) = -B(1)
      Z(1) = 0.
      DO 103 K=2,N
         Z(K) = FLOAT(K-1)*DZ
         T = 1.+Z(K)
         A(K) = T**2*DZSQ+T/DZ
         B(K) = -2.*T**2*DZSQ
         C(K) = T**2*DZSQ-T/DZ
  103 CONTINUE
C
C     GENERATE RIGHT SIDE OF EQUATION
C
      DO 106 I=1,L
         DO 105 J=1,M
            DO 104 K=2,N
               F(I,J,K) = 2.*SIN(X(I))*SIN(Y(J))*(1.+Z(K))**4
  104       CONTINUE
  105    CONTINUE
  106 CONTINUE
      DO 108 I=1,L
         DO 107 J=1,L
            F(I,J,1) = (10.+8./DZ)*SIN(X(I))*SIN(Y(J))
            F(I,J,N) = F(I,J,N)-C(N)*16.*SIN(X(I))*SIN(Y(J))
  107    CONTINUE
  108 CONTINUE
      C(N) = 0.
C
C     CALL POIS3D TO SOLVE EQUATIONS.
C
      CALL POIS3D (LPEROD,L,C1,MPEROD,M,C2,NPEROD,N,A,B,C,LDIMF,MDIMF,
     1             F,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR.  THE EXACT SOLUTION IS
C
C              U(X,Y,Z) = SIN(X)*SIN(Y)*(1+Z)**4
C
      ERR = 0.
      DO 111 I=1,L
         DO 110 J=1,M
            DO 109 K=1,N
               T = ABS(F(I,J,K)-SIN(X(I))*SIN(Y(J))*(1.+Z(K))**4)
               IF (T .GT. ERR) ERR = T
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      PRINT 1001 , IERROR,ERR
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE POIS3D EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 2.93277E-02//
     4        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     5        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5)
C
      END


      SUBROUTINE distaz(dist,az,lon1,lat1,lon2,lat2)
C----
C Given the latitude and longitude of two points, compute the great
C circle distance between them (in radians), and the azimuth from
C point 1 to point 2, in radians clockwise from north.
C
C (single precision)
C----
      IMPLICIT none
      REAL pi,d2r
      PARAMETER (pi=3.14159265,d2r=pi/1.8e2)
      REAL lon1,lat1,lon2,lat2,colat1,colat2,dlon,dlat,a
      REAL dist,az
C----
C Check if points are polar opposite
C----
      if (abs(lat1+lat2).le.1.0e-6.and.
     1                  abs(mod(lon1-lon2,1.8e2)).le.1.0e-6) then
          dist = pi
          az = 0.0e0
          goto 11
      endif
C----
C   12/13/12 - use the Haversine formula to get distance:
C              more accurate over short distances
C----
      colat1 = (9.0e1-lat1)*d2r
      colat2 = (9.0e1-lat2)*d2r
      dlon = (lon2-lon1)*d2r
      dlat = (lat2-lat1)*d2r
C----
C Spherical Law of Cosines to get distance
C----
C      arg = cos(colat1)*cos(colat2) +
C     1            sin(colat1)*sin(colat2)*cos(dlon)
C      if (arg.gt.1.0) arg = 1.0
C      dist = acos(arg)
C
C----
C Haversine Formula to get distance
C----
      a = sin(dlat/2.0e0)*sin(dlat/2.0e0) +
     1   cos(lat1*d2r)*cos(lat2*d2r)*sin(dlon/2.0e0)*sin(dlon/2.0e0)
      if (a.ge.1.0) then
          dist = 0.0e0
      else
          dist = 2.0e0*atan2(sqrt(a),sqrt(1.0-a))
      endif
C----
C Spherical Law of Sines to get azimuth
C----
      if (dist.lt.1.0e-6) then
          az = 0.0
          goto 11
      endif

      if (lat2.gt.lat1) then
          a = sin(colat2)*sin(dlon)/sin(dist)
          if (a.gt.1.0) a = 1.0e0
          if (a.lt.-1.0) a = -1.0e0
          az = asin(a)
      elseif (lat2.lt.lat1) then
          a = sin(pi-colat2)*sin(dlon)/sin(dist)
          if (a.gt.1.0) a = 1.0e0
          if (a.lt.-1.0) a = -1.0e0
          az = asin(a)
          az = pi - az
      elseif (lon1.lt.lon2) then
          az = pi/2.0e0
      else
          az = -pi/2.0e0
      endif
      if (az.lt.0.0) az = az+2.0e0*pi

   11 continue

      RETURN
      END

c----------------------------------------------------------------------c

      SUBROUTINE ddistaz(dist,az,lon1,lat1,lon2,lat2)
C----
C Given the latitude and longitude of two points, compute the great
C circle distance between them (in radians), and the azimuth from
C point 1 to point 2, in radians clockwise from north.
C
C (Double precision)
C----
      IMPLICIT none
      REAL*8 pi,d2r
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2)
      REAL*8 lon1,lat1,lon2,lat2,colat1,colat2,dlon,dlat,a
      REAL*8 dist,az
C----
C Check if points are polar opposite
C----
      if (dabs(lat1+lat2).le.1.0d-6.and.
     1                  dabs(mod(lon1-lon2,1.8d2)).le.1.0d-6) then
          dist = pi
          az = 0.0d0
          goto 11
      endif
C----
C   12/13/12 - use the Haversine formula to get distance:
C              more accurate over short distances
C----
      colat1 = (90.d0-lat1)*d2r
      colat2 = (90.d0-lat2)*d2r
      dlon = (lon2-lon1)*d2r
      dlat = (lat2-lat1)*d2r
C----
C Spherical Law of Cosines to get distance
C----
C      arg = cos(colat1)*cos(colat2) +
C     1            sin(colat1)*sin(colat2)*cos(dlon)
C      if (arg.gt.1.0) arg = 1.0
C      dist = acos(arg)
C----
C Haversine Formula to get distance
C----
      a = dsin(dlat/2.0d0)*dsin(dlat/2.0d0) +
     1   dcos(lat1*d2r)*dcos(lat2*d2r)*dsin(dlon/2.0d0)*dsin(dlon/2.0d0)
      if (a.ge.1.0d0) then
          dist = 0.0d0
      else
          dist = 2.0d0*datan2(dsqrt(a),dsqrt(1.0d0-a))
      endif
C----
C Spherical Law of Sines to get azimuth
C----
      if (dist.lt.1.0d-6) then
          az = 0.0d0
          goto 11
      endif

C      if (lat2.gt.lat1) then
C          a = dsin(colat2)*dsin(dlon)/dsin(dist)
C          if (a.gt.1.0) a = 1.0d0
C          if (a.lt.-1.0) a = -1.0d0
C          az = asin(a)
C      elseif (lat2.lt.lat1) then
C          a = dsin(pi-colat2)*dsin(dlon)/dsin(dist)
C          if (a.gt.1.0) a = 1.0d0
C          if (a.lt.-1.0) a = -1.0d0
C          az = dasin(a)
C          az = pi - az
C      elseif (lon1.lt.lon2) then
C          az = pi/2.0d0
C      else
C          az = -pi/2.0d0
C      endif
C      if (az.lt.0.0) az = az+2.0d0*pi
      az = datan2(dsin(dlon)*dcos(lat2*d2r),
     1                      dcos(lat1*d2r)*dsin(lat2*d2r)
     2                       - dsin(lat1*d2r)*dcos(lat2*d2r)*dcos(dlon))
   11 continue

      RETURN
      END

c----------------------------------------------------------------------c

      SUBROUTINE dlola(lon2,lat2,lon1,lat1,dist,az)
C----
C Subroutine for computing final (lon,lat) from (lon,lat), (dist,az)
C Units: dist (km), az (deg)
C----
      IMPLICIT none
      REAL*8 pi,d2r,r2d
      PARAMETER (pi=4.0d0*atan(1.0d0),d2r=pi/1.8d2,r2d=1.8d2/pi)
      REAL*8 lon1,lat1,lon2,lat2,dist,az

      dist = dist/6371.0d0 ! km -> rad
      az = az*d2r          ! deg -> rad
      lat1 = lat1*d2r      ! deg -> rad
      lon1 = lon1*d2r      ! deg -> rad

      lat2 = dasin(dsin(lat1)*dcos(dist)+dcos(lat1)*dsin(dist)*dcos(az))

      lon2 = lon1 + datan2(dsin(az)*dsin(dist)*dcos(lat1),
     1                           dcos(dist)-dsin(lat1)*dsin(lat2))

C     Return input values in initial units
      dist = dist*6371.0d0
      az = az*r2d
      lat1 = lat1*r2d
      lon1 = lon1*r2d

      RETURN
      END

c----------------------------------------------------------------------c

      SUBROUTINE lola(lon2,lat2,lon1,lat1,dist,az)
      IMPLICIT none
      REAL lon1,lat1,lon2,lat2,dist,az

      dist = dist/6371.0
      az = az*3.14159265/180.0
      lat1 = lat1*3.14159265/180.0
      lon1 = lon1*3.14159265/180.0

      lat2 = asin(sin(lat1)*cos(dist)+cos(lat1)*sin(dist)*cos(az))

      lon2 = lon1 + atan2(sin(az)*sin(dist)*cos(lat1),
     1                           cos(dist)-sin(lat1)*sin(lat2))

      RETURN
      END

c----------------------------------------------------------------------c

      SUBROUTINE lonlat2merc(x,y,lon,lat,c)

c Given lon/lat of a point, compute its location on a mercator map
c "c" is the scale factor, in km/radian

      IMPLICIT none
      REAL x,y,lon,lat,c,pi,r2d,d2r
      PARAMETER (pi=3.14159265,r2d=180/pi,d2r=pi/180)

      lon = lon*d2r
      lat = lat*d2r

      x = c*lon
      y = c*log(tan(pi/4+lat/2))

      lon = lon*r2d
      lat = lat*r2d

      RETURN
      END

c----------------------------------------------------------------------c

      SUBROUTINE merc2lonlat(lon,lat,x,y,c)

c Given x,y position on a mercator projection, compute the lon/lat
c "c" is the scale factor, in km/radian

      IMPLICIT none
      REAL lon,lat,x,y,c,pi,r2d
      PARAMETER (pi=3.14159265,r2d=180.0/pi)

      lon = x/c
      lat = 2*atan(exp(y/c))-pi/2

      lon = lon*r2d
      lat = lat*r2d

      RETURN
      END

c----------------------------------------------------------------------c

      SUBROUTINE NE2rtheta(r,theta,N,E)

c Given north and east vector components, calculate radius and azimuth,
c CW from north

      IMPLICIT none
      REAL r,theta,N,E

      r = sqrt(N*N + E*E)
      theta = atan2(E,N)

      RETURN
      END

c----------------------------------------------------------------------c

      SUBROUTINE utmgeo(rlon4,rlat4,rx4,ry4,utmzon,iway)
C----
C Code modified from Specfem3d
C----
      IMPLICIT none
      REAL*8 pi,d2r,r2d
      PARAMETER (pi=3.14159265d0,d2r=pi/1.8d2,r2d=1.8d2/pi)
      REAL*8 rx4,ry4,rlon4,rlat4
      INTEGER utmzon,iway ! iway=1: utm->lonlat iway=2: lonlat->utm
C WGS84 (World Geodetic System 1984)
      REAL*8 semmaj,semmin
      PARAMETER (semmaj=6378137.0d0,semmin=6356752.314245d0)
      REAL*8 scfa
      PARAMETER (scfa=0.9996d0)
C UTM grids are actually Mercators which employ the standard UTM scale factor 0.9996 and set the Easting Origin to 500,000.
      REAL*8 north,east
      PARAMETER (north=0.0d0,east=500000.0d0)

      INTEGER zone
      REAL*8 rlon,rlat
      REAL*8 e2,e4,e6,ep2,xx,yy,dlat,dlon,cm,cmr,delam
      REAL*8 f1,f2,f3,f4,rm,rn,t,c,a,e1,u,rlat1,dlat1,c1,t1,rn1,r1,d
      REAL*8 rx_save,ry_save,rlon_save,rlat_save
      LOGICAL lsouth

      dlon = 0
      dlat = 0
      xx = 0
      yy = 0

      rlon_save = rlon4
      rlat_save = rlat4
      rx_save = rx4
      ry_save = ry4

      e2=1.d0-(semmin/semmaj)**2
      e4=e2*e2
      e6=e2*e4
      ep2=e2/(1.d0-e2)

      lsouth = .false.
      if (utmzon.lt.0) lsouth = .true.
      zone = abs(utmzon)
      cm = zone*6.0d0 - 183.d0
      cmr = cm*d2r

      if (iway.eq.1) then
          xx = rx4
          yy = ry4
          if (lsouth) yy = yy - 1.d7
      else
          dlat = rlat4
          dlon = rlon4
      endif
!
!---- Lat/Lon to UTM conversion
!
      if (iway.eq.2) then
          rlon = d2r*dlon
          rlat = d2r*dlat

          delam = dlon - cm
          if (delam.lt.-180.d0) delam = delam + 360.d0
          if (delam.gt.180.d0) delam = delam - 360.d0
          delam = delam*d2r

          f1 = (1.d0 - e2/4.d0 - 3.d0*e4/64.d0 - 5.d0*e6/256d0)*rlat
          f2 = 3.d0*e2/8.d0 + 3.d0*e4/32.d0 + 45.d0*e6/1024.d0
          f2 = f2*sin(2.d0*rlat)
          f3 = 15.d0*e4/256.d0*45.d0*e6/1024.d0
          f3 = f3*sin(4.d0*rlat)
          f4 = 35.d0*e6/3072.d0
          f4 = f4*sin(6.d0*rlat)
          rm = semmaj*(f1 - f2 + f3 - f4)
          if (dabs(dlat-90.d0).lt.1.0d-6.or.
     1                          dabs(dlat+90.d0).lt.1.0d-6) then
              xx = 0.d0
              yy = scfa*rm
          else
              rn = semmaj/sqrt(1.d0 - e2*sin(rlat)**2)
              t = tan(rlat)**2
              c = ep2*cos(rlat)**2
              a = cos(rlat)*delam

              f1 = (1.d0 - t + c)*a**3/6.d0
              f2 = 5.d0 - 18.d0*t + t**2 + 72.d0*c - 58.d0*ep2
              f2 = f2*a**5/120.d0
              xx = scfa*rn*(a + f1 + f2)
              f1 = a**2/2.d0
              f2 = 5.d0 - t + 9.d0*c + 4.d0*c**2
              f2 = f2*a**4/24.d0
              f3 = 61.d0 - 58.d0*t + t**2 + 600.d0*c - 330.d0*ep2
              f3 = f3*a**6/720.d0
              yy = scfa*(rm + rn*tan(rlat)*(f1 + f2 + f3))
          endif
          xx = xx + east
          yy = yy + north
!
!---- UTM to Lat/Lon conversion
!
      else
          xx = xx - east
          yy = yy - north
          e1 = sqrt(1.d0 - e2)
          e1 = (1.d0 - e1)/(1.d0 + e1)
          rm = yy/scfa
          u = 1.d0 - e2/4.d0 - 3.d0*e4/64.d0 - 5.d0*e6/256.d0
          u = rm/(semmaj*u)

          f1 = 3.d0*e1/2.d0 - 27.d0*e1**3.d0/32.d0
          f1 = f1*sin(2.d0*u)
          f2 = 21.d0*e1**2/16.d0 - 55.d0*e1**4/32.d0
          f2 = f2*sin(4.d0*u)
          f3 = 151.d0*e1**3.d0/96.d0
          f3 = f3*sin(6.d0*u)
          rlat1 = u + f1 + f2 + f3
          dlat1 = rlat1*r2d
          if (dlat1.ge.90.d0.or.dlat1.le.-90.d0) then
              dlat1 = dmin1(dlat1,90.d0)
              dlat1 = dmax1(dlat1,-90.d0)
              dlon = cm
          else
              c1 = ep2*cos(rlat1)**2
              t1 = tan(rlat1)**2
              f1 = 1.d0 - e2*sin(rlat1)**2
              rn1 = semmaj/sqrt(f1)
              r1 = semmaj*(1.d0 - e2)/sqrt(f1**3)
              d = xx/(rn1*scfa)

              f1 = rn1*tan(rlat1)/r1
              f2 = d**2/2.d0
              f3 = 5.d0*3.d0*t1 + 10.d0*c1 - 4.d0*c1**2 - 9.d0*ep2
              f3 = f3*d**2*d**2/24.d0
              f4 = 61.d0 + 90.d0*t1 + 298.d0*c1 + 45.d0*t1**2
     1                                         - 252.d0*ep2 - 3.d0*c1**2
              f4 = f4*(d**2)**3.d0/720.d0
              rlat = rlat1 - f1*(f2 - f3 + f4)
              dlat = rlat*r2d

              f1 = 1.d0 + 2.d0*t1 + c1
              f1 = f1*d**2*d/6.d0
              f2 = 5.d0 - 2.d0*c1 + 28.d0*t1 - 3.d0*c1**2 + 8.d0*ep2
     1                                                    + 24.d0*t1**2
              f2 = f2*(d**2)**2*d/120.d0
              rlon = cmr + (d - f1 + f2)/cos(rlat1)
              dlon = rlon*r2d
              if (dlon.lt.-180.d0) dlon = dlon + 360.d0
              if (dlon.gt.180.d0) dlon = dlon - 360.d0
          endif
      endif

!
!----- output
!
      if (iway.eq.1) then
          rlon4 = dlon
          rlat4 = dlat
          rx4 = rx_save
          ry4 = ry_save
      else
          rx4 = xx
          if (lsouth) yy = yy + 1.d7
          ry4 = yy
          rlon4 = rlon_save
          rlat4 = rlat_save
      endif

      RETURN
      END