!*******************************************************
!
!   TO TEST mo_combinatorics
!
!*******************************************************
program combinatorics

  use mo_kind,          only: i4, i8, sp, dp
  use mo_combinatorics, only: binomcoeffi!, factorial
  use mo_combinatorics, only: nextpart, prevpart, isgoodpart
  use mo_functions,     only: factorial
  use mo_combinatorics, only: next_kofn,   all_kofn,   random_kofn
  use mo_combinatorics, only: next_index_permut, all_index_permut, random_index_permut, random_permut
  use mo_xor4096,       only: xor4096, n_save_state
  use mo_ansi_colors, only: color, c_red, c_green

  implicit none

  integer(i4)                          :: c_i4
  integer(i8)                          :: c_i8
  real(sp)                             :: c_sp
  real(dp)                             :: c_dp
  integer(i4)                          :: i
  integer(i4), dimension(3)            :: next_i4
  integer(i4), dimension(4)            :: next_4_i4
  integer(i4)                          :: iseed
  real(sp)                             :: rn
  integer(i4), dimension(n_save_state) :: save_state_i4
  integer(i4), dimension(3)            :: random_i4
  integer(i4), allocatable             :: all_i4(:,:)
  integer(i4), dimension(4)            :: permut_i4

  integer(i4), dimension(4)            :: part_i4
  integer(i4), dimension(4)            :: part_i8

!  integer(i4), dimension(5)            :: part5_i4

  logical                              :: isgood

  ! integer(i4)                          :: j, nn
  ! integer(i4), dimension(4,4)          :: count_permut_i4

  isgood = .true.
  write(*,*) ''

  !--------------------------------------------------
  ! Test: Binomial Coefficient
  !--------------------------------------------------

  c_i4 = binomcoeffi(5_i4, 3_i4)
  write(*,*) 'BINOMCOEFFI (5,3)                : ', c_i4
  if ( c_i4 .ne. 10_i4 ) isgood = .false.

  c_i8 = binomcoeffi(5_i8, 3_i8)
  write(*,*) 'BINOMCOEFFI (5,3)                : ', c_i8
  if ( c_i8 .ne. 10_i8 ) isgood = .false.

  c_sp = binomcoeffi(5.5_sp, 3_i4)
  write(*,*) 'BINOMCOEFFI (11/2,3)             : ', c_sp
  if ( int(c_sp*10000) .ne. 144375 ) isgood = .false.

  c_dp = binomcoeffi(5.5_dp, 3_i8)
  write(*,*) 'BINOMCOEFFI (11/2,3)             : ', c_dp
  if ( int(c_dp*10000) .ne. 144375 ) isgood = .false.

  !--------------------------------------------------
  ! Test: Factorial
  !--------------------------------------------------

  c_i4 = factorial(5)
  write(*,*) 'FACTORIAL 5!                     : ', c_i4
  if ( c_i4 .ne. 120_i4 ) isgood = .false.
  write(*,*) ' '

  !--------------------------------------------------
  ! Test: Random k of n subset
  !--------------------------------------------------

  iseed=1045_i4
  call xor4096(iSeed, rn, save_state=save_state_i4)

  random_i4 = random_kofn(5,3,save_state=save_state_i4)
  write(*,*) 'RANDOM_KOFN (5,3)                : ', random_i4
  if ( any(random_i4(:) .ne. (/ 1_i4, 3_i4, 4_i4 /)) ) isgood = .false.

  !--------------------------------------------------
  ! Test: Next k of n subset
  !--------------------------------------------------

  next_i4 = next_kofn(5,3,(/1,4,5/))
  write(*,*) 'NEXT_KOFN subset after (/1,4,5/) : ', next_i4
  if ( any(next_i4 .ne. (/ 2_i4, 3_i4, 4_i4 /)) ) isgood = .false.

  !--------------------------------------------------
  ! Test: All k of n subset
  !--------------------------------------------------

  allocate(all_i4(binomcoeffi(5,3),3))

  all_i4 = all_kofn(5,3)
  write(*,*) 'ALL_KOFN (5,3)                   : '
  do i=1,size(all_i4,1)
     write(*,*) '         subset #',i,'   ',all_i4(i,:)
  end do
  if ( any(all_i4(5,:) .ne. (/ 1_i4, 3_i4, 5_i4 /)) ) isgood = .false.
  write(*,*) ' '

  deallocate(all_i4)

  !--------------------------------------------------
  ! Test: Random index permutation
  !--------------------------------------------------

  iseed=1206_i4
  call xor4096(iSeed, rn, save_state=save_state_i4)

  ! count_permut_i4 = 0
  ! nn = 100000
  ! do i=1, nn
  !    permut_i4 = random_index_permut(4_i4)
  !    forall(j=1:4) count_permut_i4(permut_i4(j),j) = count_permut_i4(permut_i4(j),j) + 1
  !    !write(*,*) 'RANDOM_INDEX_PERMUT of 4                  : ',permut_i4
  ! end do
  ! print*, nn/4
  ! print*, count_permut_i4
  permut_i4 = random_index_permut(4_i4)
  write(*,*) 'RANDOM_INDEX_PERMUT of 4                  : ',permut_i4
  if ( any(permut_i4(:) .ne. (/ 4_i4, 1_i4, 2_i4, 3_i4 /)) ) isgood = .false.

  !--------------------------------------------------
  ! Test: Next index permutation
  !--------------------------------------------------

  next_4_i4 = next_index_permut(4,(/4,1,2,3/))
  write(*,*) 'NEXT_INDEX_PERMUT permutation after (/4,1,2,3/) : ', next_4_i4
  if ( any(next_4_i4(:) .ne. (/ 2_i4, 1_i4, 4_i4, 3_i4 /)) ) isgood = .false.

  !--------------------------------------------------
  ! Test: All index permutations
  !--------------------------------------------------
  allocate(all_i4(factorial(3),3))

  all_i4 = all_index_permut(3)
  write(*,*) 'ALL_INDEX_PERMUT of 3                     : '
  do i=1,size(all_i4,1)
     write(*,*) '    permutation #',i,'   ',all_i4(i,:)
  end do
  if ( any(all_i4(6,:) .ne. (/ 3_i4, 2_i4, 1_i4 /)) ) isgood = .false.

  deallocate(all_i4)

  !--------------------------------------------------
  ! Test: Random permutation
  !--------------------------------------------------

  iseed=1206_i4
  call xor4096(iSeed, rn, save_state=save_state_i4)

  forall(i=1:4) permut_i4(i) = i+6
  call random_permut(permut_i4)
  write(*,*) 'RANDOM_PERMUT of 4                  : ',permut_i4
  if ( any(permut_i4(:) .ne. (/ 10_i4, 7_i4, 8_i4, 9_i4 /)) ) isgood = .false.

  !--------------------------------------------------
  ! Test: Partitions
  !--------------------------------------------------

  part_i4       = 0_i4
  part_i8       = 0_i8

  part_i4(4)    = 1_i4
  part_i8(4)    = 1_i8

  write (*,*) " "
  write (*,*) "Calculation of the Partition:"
  write (*,*) "1. Partition_i4 of 4: ", part_i4
  if(.not. isgoodpart(part_i4)) isgood  = .false.
  part_i4       =   nextpart(part_i4)
  write (*,*) "2. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/1_i4,0_i4,1_i4,0_i4/) ))) isgood  = .false.
  part_i4       =   nextpart(part_i4)
  write (*,*) "3. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/0_i4,2_i4,0_i4,0_i4/) ))) isgood  = .false.
  part_i4       =   nextpart(part_i4)
  write (*,*) "4. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/2_i4,1_i4,0_i4,0_i4/) ))) isgood  = .false.
  part_i4       =   nextpart(part_i4)
  write (*,*) "5. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/4_i4,0_i4,0_i4,0_i4/) ))) isgood  = .false.

  write (*,*) "1. Partition_i8 of 4: ", part_i8
  if(.not. isgoodpart(part_i8)) isgood  = .false.
  part_i8       =   nextpart(part_i8)
  write (*,*) "2. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/1_i8,0_i8,1_i8,0_i8/) ))) isgood  = .false.
  part_i8       =   nextpart(part_i8)
  write (*,*) "3. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/0_i8,2_i8,0_i8,0_i8/) ))) isgood  = .false.
  part_i8       =   nextpart(part_i8)
  write (*,*) "4. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/2_i8,1_i8,0_i8,0_i8/) ))) isgood  = .false.
  part_i8       =   nextpart(part_i8)
  write (*,*) "5. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/4_i8,0_i8,0_i8,0_i8/) ))) isgood  = .false.

  write (*,*) " "
  write (*,*) "Reverse calculation of the Partition:"
  write (*,*) "5. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/4_i4,0_i4,0_i4,0_i4/) ))) isgood  = .false.
  part_i4       =   prevpart(part_i4)
  write (*,*) "4. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/2_i4,1_i4,0_i4,0_i4/) ))) isgood  = .false.
  part_i4       =   prevpart(part_i4)
  write (*,*) "3. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/0_i4,2_i4,0_i4,0_i4/) ))) isgood  = .false.
  part_i4       =   prevpart(part_i4)
  write (*,*) "2. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/1_i4,0_i4,1_i4,0_i4/) ))) isgood  = .false.
  part_i4       =   prevpart(part_i4)
  write (*,*) "1. Partition_i4 of 4: ", part_i4
  if(.not. (isgoodpart(part_i4) .and. all(part_i4 == (/0_i4,0_i4,0_i4,1_i4/) ))) isgood  = .false.

  write (*,*) "5. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/4_i8,0_i8,0_i8,0_i8/) ))) isgood  = .false.
  part_i8       =   prevpart(part_i8)
  write (*,*) "4. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/2_i8,1_i8,0_i8,0_i8/) ))) isgood  = .false.
  part_i8       =   prevpart(part_i8)
  write (*,*) "3. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/0_i8,2_i8,0_i8,0_i8/) ))) isgood  = .false.
  part_i8       =   prevpart(part_i8)
  write (*,*) "2. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/1_i8,0_i8,1_i8,0_i8/) ))) isgood  = .false.
  part_i8       =   prevpart(part_i8)
  write (*,*) "1. Partition_i8 of 4: ", part_i8
  if(.not. (isgoodpart(part_i8) .and. all(part_i8 == (/0_i8,0_i8,0_i8,1_i8/) ))) isgood  = .false.

!  part5_i4      = 0_i4
!  part5_i4(5)   = 1_i4
!
!  write(*,*) ""
!  write(*,*) "Partitions of 5:"
!  do i=1_i4, 6
!  write (*,*) part5_i4
!  part5_i4      =   nextpart(part5_i4)
!  end do
!  write (*,*) part5_i4

!  write(*,*) ""
!  write(*,*) "reverse Partitions of 5:"
!  do i=1_i4, 6
!  write (*,*) part5_i4
!  part5_i4      =   prevpart(part5_i4)
!  end do
!  write (*,*) part5_i4

  write(*,*) ''
  if (isgood) then
     write(*,*) 'mo_combinatorics ', color('o.k.', c_green)
  else
     write(*,*) 'mo_combinatorics ', color('failed', c_red)
  end if

end program combinatorics


program regre
integer i
real x(4),y(4),Sx,Sy,Sxy,Sxx,Syy,a,b,r
data Sx,Sy,Sxy,Sxx,Syy,a,b,r /8*0/
do 1 i = 1,4
1	read(*,*)x(i),y(i)
do 2 i = 1,4
	Sx = Sx + x(i)
	Sy = Sy + y(i)
	Sxy = Sxy + (x(i)*y(i))
	Sxx = Sxx + (x(i)*x(i))
2	Syy = Syy + (y(i)*y(i))
a = (4*Sxy - Sx*Sy)/(4*Sxx - Sx*Sx)
b = (Sy*Sxx - Sx*Sxy)/(4*Sxx - (Sx*Sx))
!r = (4*Sxy - Sx*Sy)/(sqrt((4*Sxx - (Sx*Sx))*(4*Syy - (Sy*Sy))))
r = (4*Sxy - Sx*Sy)/(sqrt(4*Sxx - (Sx*Sx))*sqrt(4*Syy - (Sy*Sy)))
write(*,*)a,b,r
stop
end program


      REAL FUNCTION BUBFNC(RLAT)
C
C SPECIFIES FUNCTIONAL FORM OF U BAR
C (USED FOR FORCED SOLUTION ICOND = 4)
C SEE PAPER BY BROWNING ET. AL.:
C A COMPARISON OF THREE NUMERICAL METHODS ...
C (EQUATION 5.10a)*COS(RLAT)
C
C CALLED BY: ANLYTC, ERRANL, FORCE, FUNC2
C CALLS:
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Common Blocks ----------------------------------------------------
C
C     Case 4 variables
      INCLUDE 'case4.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C LATITUDE
      REAL RLAT
C
C----- Executable Statements -------------------------------------------
C
      BUBFNC = SU0*(2.0*SIN(RLAT)*COS(RLAT))**NPWR
C
      RETURN
      END


      PROGRAM TB0103

      IMPLICIT NONE

*----------- VARIABLE DECLARATION -------------------------------------

* FUNCTION DECLARATION
*   SxP: APPROXIMATE FUNCTIONS BY x POINTS
*   SFUNC: THE FUNCTION WE ARE DISCUSSING
*   SINTG: INTEGRAL OF SFUNC
*   D...: ALL WORKING IN THE DOUBLE PRECISION
*   S...: ALL WORKING IN THE SINGLE PRECISION
      REAL              S2P, S3P, S4P, S5P, SFUNC, SINTG
      EXTERNAL          S2P, S3P, S4P, S5P, SFUNC, SINTG
      DOUBLE PRECISION  D2P, D3P, D4P, D5P, DFUNC, DINTG
      EXTERNAL          D2P, D3P, D4P, D5P, DFUNC, DINTG

* ERROR CALCULATION VARIABLES
*   N: LOADED INTERNAL POINTS
*   SH: LOADED POINT INTERVALS
*   SMIN: INTEGRAL LOWER LIMIT
*   SMAX: INTEGRAL UPPER LIMIT
      REAL              SH, SMIN, SMAX
      DOUBLE PRECISION  DH, DMIN, DMAX
      INTEGER           N

* DUMMY
      INTEGER           I

*----------------------------------------------------------------------

* FILE OPERATION

      OPEN (11, FILE='Table-1-3.txt')

 1000 FORMAT ( 1X, I4, F12.7, 4(F12.6) )
 1001 FORMAT ( 1X, A4, A12, 4(A12) )
 1002 FORMAT ( A1, A32, A32, A1 )

* SINGLE PRECISION

      WRITE(11,*)
      WRITE(11,1002) '-','-----------------------------Sin',
     $               'gle-----------------------------','-'
      WRITE(11,1001) '    ', '            ', ' Trapezoidal',
     $               '     Simpson', ' Simpson 3/8', '       Boole'
      WRITE(11,1001) '   N', '           h', '    Eq.(1.9)',
     $               '   Eq.(1.12)', '  Eq.(1.13a)', '  Eq.(1.13b)'
      WRITE(11,1002) '-','--------------------------------',
     $               '--------------------------------','-'

      N = 2
      SMAX = 1.0E0
      SMIN = 0.0E0
      DO 10 I = 1, 6
        N = N * 2
        SH = (SMAX - SMIN) / REAL(N)
        WRITE(11,1000) N, SH,
     $                 S2P(N, SFUNC, SINTG, SMIN, SMAX),
     $                 S3P(N, SFUNC, SINTG, SMIN, SMAX),
     $                 S4P(N, SFUNC, SINTG, SMIN, SMAX),
     $                 S5P(N, SFUNC, SINTG, SMIN, SMAX)
  10  CONTINUE

      WRITE(11,1002) '-','--------------------------------',
     $               '--------------------------------','-'

* DOUBLE PRECISION

      WRITE(11,*)
      WRITE(11,1002) '-','-----------------------------Dou',
     $               'ble-----------------------------','-'
      WRITE(11,1001) '    ', '            ', ' Trapezoidal',
     $               '     Simpson', ' Simpson 3/8', '       Boole'
      WRITE(11,1001) '   N', '           h', '    Eq.(1.9)',
     $               '   Eq.(1.12)', '  Eq.(1.13a)', '  Eq.(1.13b)'
      WRITE(11,1002) '-','--------------------------------',
     $               '--------------------------------','-'

      N = 2
      DMAX = 1.0D0
      DMIN = 0.0D0
      DO 20 I = 1, 6
        N = N * 2
        DH = (DMAX - DMIN) / DBLE(N)
        WRITE(11,1000) N, DH,
     $                 D2P(N, DFUNC, DINTG, DMIN, DMAX),
     $                 D3P(N, DFUNC, DINTG, DMIN, DMAX),
     $                 D4P(N, DFUNC, DINTG, DMIN, DMAX),
     $                 D5P(N, DFUNC, DINTG, DMIN, DMAX)
  20  CONTINUE

      WRITE(11,1002) '-','--------------------------------',
     $               '--------------------------------','-'

* DISCUSSION

      WRITE(11,*)
      WRITE(11,*) 'However, this method is still not stable when'
      WRITE(11,*) 'N is very large:'

      WRITE(11,*)
      WRITE(11,1002) '-','-----------------------------Sin',
     $               'gle-----------------------------','-'
      WRITE(11,1001) '    ', '            ', ' Trapezoidal',
     $               '     Simpson', ' Simpson 3/8', '       Boole'
      WRITE(11,1001) '   N', '           h', '    Eq.(1.9)',
     $               '   Eq.(1.12)', '  Eq.(1.13a)', '  Eq.(1.13b)'
      WRITE(11,1002) '-','--------------------------------',
     $               '--------------------------------','-'

      N = 128
      SMAX = 1.0E0
      SMIN = 0.0E0
      DO 30 I = 1, 6
        N = N * 4
        SH = (SMAX - SMIN) / REAL(N)
        WRITE(11,1000) N, SH,
     $                 S2P(N, SFUNC, SINTG, SMIN, SMAX),
     $                 S3P(N, SFUNC, SINTG, SMIN, SMAX),
     $                 S4P(N, SFUNC, SINTG, SMIN, SMAX),
     $                 S5P(N, SFUNC, SINTG, SMIN, SMAX)
  30  CONTINUE

      WRITE(11,1002) '-','--------------------------------',
     $               '--------------------------------','-'

      WRITE(11,*)
      WRITE(11,1002) '-','-----------------------------Dou',
     $               'ble-----------------------------','-'
      WRITE(11,1001) '    ', '            ', ' Trapezoidal',
     $               '     Simpson', ' Simpson 3/8', '       Boole'
      WRITE(11,1001) '   N', '           h', '    Eq.(1.9)',
     $               '   Eq.(1.12)', '  Eq.(1.13a)', '  Eq.(1.13b)'
      WRITE(11,1002) '-','--------------------------------',
     $               '--------------------------------','-'

      N = 128
      DMAX = 1.0D0
      DMIN = 0.0D0
      DO 40 I = 1, 6
        N = N * 4
        DH = (DMAX - DMIN) / DBLE(N)
        WRITE(11,1000) N, DH,
     $                 D2P(N, DFUNC, DINTG, DMIN, DMAX),
     $                 D3P(N, DFUNC, DINTG, DMIN, DMAX),
     $                 D4P(N, DFUNC, DINTG, DMIN, DMAX),
     $                 D5P(N, DFUNC, DINTG, DMIN, DMAX)
  40  CONTINUE

      WRITE(11,1002) '-','--------------------------------',
     $               '--------------------------------','-'

      END

*----------------------------------------------------------------------

      FUNCTION S2P(N, SFUNC, SINTG, SMIN, SMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      REAL              S2P, SFUNC, SINTG, SMIN, SMAX
      EXTERNAL          SFUNC, SINTG
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      REAL              SH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

      SH = (SMAX - SMIN) / REAL(N)

      S2P = SFUNC(SMIN) + SFUNC(SMAX)

      K = N-1

      DO 10 I = 1, K
        S2P = S2P + 2.0E0 * SFUNC(SMIN + REAL(I) * SH)
  10  CONTINUE

      S2P = S2P * SH / 2.0E0 - SINTG(SMAX) + SINTG(SMIN)

      RETURN
      END FUNCTION S2P

*----------------------------------------------------------------------

      FUNCTION S3P(N, SFUNC, SINTG, SMIN, SMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      REAL              S3P, SFUNC, SINTG, SMIN, SMAX
      INTEGER           FLR
      EXTERNAL          SFUNC, SINTG, FLR
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      REAL              SH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

* DEFINING THE INTEGRAL GRIDS
      K = FLR(REAL(N) / 2.0E0)
      SH = (SMAX - SMIN) / (2.0E0 * REAL(K))

* INITIAL AND FINAL POINT CALCULATION
      S3P = SFUNC(SMIN) - SFUNC(SMAX)

* INTERNAL GRID POINT CALCULATION
      DO 10 I = 1, K
        S3P = S3P + 4.0E0 * SFUNC(SMIN + REAL(I*2-1) * SH)
        S3P = S3P + 2.0E0 * SFUNC(SMIN + REAL(I*2) * SH)
  10  CONTINUE

      S3P = S3P * SH / 3.0E0 - SINTG(SMAX) + SINTG(SMIN)

      RETURN
      END FUNCTION S3P

*----------------------------------------------------------------------

      FUNCTION S4P(N, SFUNC, SINTG, SMIN, SMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      REAL              S4P, SFUNC, SINTG, SMIN, SMAX
      INTEGER           FLR
      EXTERNAL          SFUNC, SINTG, FLR
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      REAL              SH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

* DEFINING THE INTEGRAL GRIDS
      K = FLR(REAL(N) / 3.0E0)
      SH = (SMAX - SMIN) / (3.0E0 * REAL(K))

* INITIAL AND FINAL POINT CALCULATION
      S4P = SFUNC(SMIN) - SFUNC(SMAX)

* INTERNAL GRID POINT CALCULATION
      DO 10 I = 1, K
        S4P = S4P + 3.0E0 * SFUNC(SMIN + REAL(I*3-2) * SH)
        S4P = S4P + 3.0E0 * SFUNC(SMIN + REAL(I*3-1) * SH)
        S4P = S4P + 2.0E0 * SFUNC(SMIN + REAL(I*3) * SH)
  10  CONTINUE

      S4P = S4P * SH * 3.0E0 / 8.0E0 - SINTG(SMAX) + SINTG(SMIN)

      RETURN
      END FUNCTION S4P

*-----------------------------------------------------------------------

      FUNCTION S5P(N, SFUNC, SINTG, SMIN, SMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      REAL              S5P, SFUNC, SINTG, SMIN, SMAX
      INTEGER           FLR
      EXTERNAL          SFUNC, SINTG, FLR
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      REAL              SH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

* DEFINING THE INTEGRAL GRIDS
      K = FLR(REAL(N) / 4.0E0)
      SH = (SMAX - SMIN) / (4.0E0 * REAL(K))

* INITIAL AND FINAL POINT CALCULATION
      S5P = 7.0E0 * SFUNC(SMIN) - 7.0E0 * SFUNC(SMAX)

* INTERNAL GRID POINT CALCULATION
      DO 10 I = 1, K
        S5P = S5P + 32.0E0 * SFUNC(SMIN + REAL(I*4-3) * SH)
        S5P = S5P + 12.0E0 * SFUNC(SMIN + REAL(I*4-2) * SH)
        S5P = S5P + 32.0E0 * SFUNC(SMIN + REAL(I*4-1) * SH)
        S5P = S5P + 14.0E0 * SFUNC(SMIN + REAL(I*4) * SH)
  10  CONTINUE

      S5P = S5P * SH * 2.0E0 / 45.0E0 - SINTG(SMAX) + SINTG(SMIN)

      RETURN
      END FUNCTION S5P

*-----------------------------------------------------------------------

      FUNCTION D2P(N, DFUNC, DINTG, DMIN, DMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  D2P, DFUNC, DINTG, DMIN, DMAX
      EXTERNAL          DFUNC, DINTG
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      DOUBLE PRECISION  DH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

      DH = (DMAX - DMIN) / DBLE(N)

      D2P = DFUNC(DMIN) + DFUNC(DMAX)

      K = N-1

      DO 10 I = 1, K
        D2P = D2P + 2.0D0 * DFUNC(DMIN + DBLE(I) * DH)
  10  CONTINUE

      D2P = D2P * DH / 2.0D0 - DINTG(DMAX) + DINTG(DMIN)

      RETURN
      END FUNCTION D2P

*----------------------------------------------------------------------

      FUNCTION D3P(N, DFUNC, DINTG, DMIN, DMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  D3P, DFUNC, DINTG, DMIN, DMAX
      INTEGER           FLR
      EXTERNAL          DFUNC, DINTG, FLR
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      DOUBLE PRECISION  DH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

* DEFINING THE INTEGRAL GRIDS
      K = FLR(REAL(DBLE(N) / 2.0D0))
      DH = (DMAX - DMIN) / (2.0D0 * DBLE(K))

* INITIAL AND FINAL POINT CALCULATION
      D3P = DFUNC(DMIN) - DFUNC(DMAX)

* INTERNAL GRID POINT CALCULATION
      DO 10 I = 1, K
        D3P = D3P + 4.0D0 * DFUNC(DMIN + DBLE(I*2-1) * DH)
        D3P = D3P + 2.0D0 * DFUNC(DMIN + DBLE(I*2) * DH)
  10  CONTINUE

      D3P = D3P * DH / 3.0D0 - DINTG(DMAX) + DINTG(DMIN)

      RETURN
      END FUNCTION D3P

*----------------------------------------------------------------------

      FUNCTION D4P(N, DFUNC, DINTG, DMIN, DMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  D4P, DFUNC, DINTG, DMIN, DMAX
      INTEGER           FLR
      EXTERNAL          DFUNC, DINTG, FLR
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      DOUBLE PRECISION  DH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

* DEFINING THE INTEGRAL GRIDS
      K = FLR(REAL(DBLE(N) / 3.0D0))
      DH = (DMAX - DMIN) / (3.0D0 * DBLE(K))

* INITIAL AND FINAL POINT CALCULATION
      D4P = DFUNC(DMIN) - DFUNC(DMAX)

* INTERNAL GRID POINT CALCULATION
      DO 10 I = 1, K
        D4P = D4P + 3.0D0 * DFUNC(DMIN + DBLE(I*3-2) * DH)
        D4P = D4P + 3.0D0 * DFUNC(DMIN + DBLE(I*3-1) * DH)
        D4P = D4P + 2.0D0 * DFUNC(DMIN + DBLE(I*3) * DH)
  10  CONTINUE

      D4P = D4P * DH * 3.0D0 / 8.0D0 - DINTG(DMAX) + DINTG(DMIN)

      RETURN
      END FUNCTION D4P

*-----------------------------------------------------------------------

      FUNCTION D5P(N, DFUNC, DINTG, DMIN, DMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  D5P, DFUNC, DINTG, DMIN, DMAX
      INTEGER           FLR
      EXTERNAL          DFUNC, DINTG, FLR
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      DOUBLE PRECISION  DH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

* DEFINING THE INTEGRAL GRIDS
      K = FLR(REAL(DBLE(N) / 4.0D0))
      DH = (DMAX - DMIN) / (4.0D0 * DBLE(K))

* INITIAL AND FINAL POINT CALCULATION
      D5P = 7.0D0 * DFUNC(DMIN) - 7.0D0 * DFUNC(DMAX)

* INTERNAL GRID POINT CALCULATION
      DO 10 I = 1, K
        D5P = D5P + 32.0D0 * DFUNC(DMIN + DBLE(I*4-3) * DH)
        D5P = D5P + 12.0D0 * DFUNC(DMIN + DBLE(I*4-2) * DH)
        D5P = D5P + 32.0D0 * DFUNC(DMIN + DBLE(I*4-1) * DH)
        D5P = D5P + 14.0D0 * DFUNC(DMIN + DBLE(I*4) * DH)
  10  CONTINUE

      D5P = D5P * DH * 2.0D0 / 45.0D0 - DINTG(DMAX) + DINTG(DMIN)

      RETURN
      END FUNCTION D5P

*-----------------------------------------------------------------------

      FUNCTION SFUNC(SVAR)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      REAL              SFUNC, SVAR

      SFUNC = EXP(SVAR)

      RETURN
      END FUNCTION SFUNC

*-----------------------------------------------------------------------

      FUNCTION SINTG(SVAR)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      REAL              SINTG, SVAR

      SINTG = EXP(SVAR)

      RETURN
      END FUNCTION SINTG

*----------------------------------------------------------------------

      FUNCTION DFUNC(DVAR)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  DFUNC, DVAR

      DFUNC = DEXP(DVAR)

      RETURN
      END FUNCTION DFUNC

*-----------------------------------------------------------------------

      FUNCTION DINTG(DVAR)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  DINTG, DVAR

      DINTG = DEXP(DVAR)

      RETURN
      END FUNCTION DINTG

*-----------------------------------------------------------------------

      FUNCTION FLR(SVAR)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      REAL              SVAR
      INTEGER           FLR

* MAIN PROGRAM

      FLR = INT(SVAR)

      IF (SVAR .LT. 0) FLR = FLR - 1

      RETURN
      END FUNCTION FLR


subroutine Calculate_PAR(I_0, nlev_, Hz, Chl, PAR, PARw)
  !top level is nlev_, bottom layer is 1, following ROMS convention
  implicit none
  real   , intent(in) :: I_0
  integer, intent(in) :: nlev_    ! Total number of vertical layers
  real   , intent(in) :: Hz(nlev_), Chl(nlev_)
  real   , intent(out):: PAR(nlev_),PARw(0:nlev_)
  integer             :: i
  real                :: par0, attn    ! Scratch variable
  real   , parameter  :: kw = 0.04, kc = 0.025

  par0         = I_0   !Light at the grid surface
  parw(nlev_)  = I_0
  do i = nlev_,1,-1

     attn   = exp(-0.5*Hz(i)*(kw + kc*Chl(i)))
     PAR(i) = par0*attn
     par0   = PAR(i)*attn
     PARw(i-1) = par0
  enddo
end subroutine Calculate_PAR


c fishpk31 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
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     program to illustrate the use of hstplr to solve the equation
c
c     (1/r)(d/dr)(r*du/dr) + (1/r**2)(d/dtheta)(du/dtheta) = 16*r**2
c
c     on the quarter-disk 0 .lt. r .lt. 1 and 0 .lt. theta .lt. pi/2
c     with the boundary conditions
c
c     u(1,theta) = 1 - cos(4*theta)  for  0 .le. theta .le. pi/2
c
c     and
c
c     (du/dr)(r,0) = (du/dr)(r,pi/2) = 0  for  o .lt. r .lt. 1 .
c
c     note that u at the origin is unspecified.  the exact solution to
c     this problem is
c
c               u(r,theta) = (r**4)(1-cos(4*theta)) .
c
c     we will use 50 unknowns in the r-interval and 48 unknowns in
c     the theta-interval.
c
      program thstplr
      dimension       f(51,50)   ,bdb(48)    ,bdc(50)    ,bdd(50)    ,
     1                w(1092)    ,r(50)      ,theta(48)
      dimension bda(1)
c
c     from dimension statement we get value of idimf.  also note that w
c     is dimensioned (13 + log2(n))*m + 4*n .
c
      idimf = 51
      a = 0.
      b = 1.
      m = 50
      mbdcnd = 5
      c = 0.
      pi = pimach(dum)
      d = pi/2.
      n = 48
      nbdcnd = 3
      elmbda = 0.
c
c     generate and store grid points for the purpose of computing
c     boundary data and the right side of the poisson equation.
c
      do 101 i=1,m
         r(i) = (float(i)-0.5)/50.
  101 continue
      do 102 j=1,n
         theta(j) = (float(j)-0.5)*pi/96.
  102 continue
c
c     generate boundary data.
c
      do 103 j=1,n
         bdb(j) = 1.-cos(4.*theta(j))
  103 continue
      do 104 i=1,m
         bdc(i) = 0.
         bdd(i) = 0.
  104 continue
c
c     bda is a dummy variable.
c
c
c     generate right side of equation.
c
      do 106 i=1,m
         do 105 j=1,n
            f(i,j) = 16.*r(i)**2
  105    continue
  106 continue
      call hstplr (a,b,m,mbdcnd,bda,bdb,c,d,n,nbdcnd,bdc,bdd,elmbda,f,
     1             idimf,pertrb,ierror,w)
c
c     compute discretization error.  the exact solution is
c
c                u(r,theta) = r**4*(1 - cos(4*theta))
c
      err = 0.
      do 108 i=1,m
         do 107 j=1,n
            z = abs(f(i,j)-r(i)**4*(1.-cos(4.*theta(j))))
            if (z .gt. err) err = z
  107    continue
  108 continue
      print 1001 , ierror,err,w(1)
      stop
c
 1001 format (1h1,20x,25hsubroutine hstplr example///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/
     3        18x,34hdiscretization error = 1.13038e-03/
     4        12x,33hrequired length of w array = 1042//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/18x,22hdiscretization error =,e12.5/
     7        12x,28hrequired length of w array =,f5.0)
c
      end


program main

  real :: area
  real :: pi = 4 * atan (1.0)
  integer :: num = 42

  Print *, "Hello World!!!"
  Print *, pi
  Print *, num

  if (num > 42) then
    print*, "The number is > 42!"
  else if (num < 42) then
    print*, "The number is < 42!"
  else if (num /= 42) then
    print*, "The number is NOT 42!"
  else
    print*, "It's 42!!!"
  end if

  do while (num >= 0)
    print*,  num
    num = num - 1
  end do

  area = area_of_circle(4.2)
  Print *, area

end program main

function area_of_circle(radius)

  real :: pi = 4 * atan (1.0)
  area_of_circle = pi * radius**2

end function area_of_circle


subroutine units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2)
  use amr_commons
  use hydro_commons
  use cooling_module
  use poisson_commons
  real(dp)::scale_nH,scale_T2,scale_t,scale_v,scale_d,scale_l
  !-----------------------------------------------------------------------
  ! Conversion factors from user units into cgs units
  ! For gravity runs, make sure that G=1 in user units.
  !-----------------------------------------------------------------------
  real(dp)::v200,c,r200,h

  v200 = gravity_params(1) ! Virial velocity of the halo (km.s-1)
  c = gravity_params(2)    ! Concentration of the halo

  ! NFW scale radius
  h = 0.7
  r200 = v200*1d5/sqrt(2d0*twopi*6.67d-8/3.*200.*rhoc*h**2)

  ! scale_d converts mass density from user units into g/cc
  scale_d = rhoc*h**2*200./3.0*c*c*c/(log(1d0+c)-c/(1d0+c))

  ! scale_t converts time from user units into seconds
  scale_t = 1.0/sqrt(6.67d-8*scale_d)

  ! scale_l converts distance from user units into cm
  scale_l = r200/c

  ! scale_v convert velocity in user units into cm/s
  scale_v = scale_l / scale_t

  ! scale_T2 converts (P/rho) in user unit into (T/mu) in Kelvin
  scale_T2 = mH/kB * scale_v**2

  ! scale_nH converts rho in user units into nH in H/cc
  scale_nH = X/mH * scale_d

end subroutine units


! Created by EverLookNeverSee@GitHub on 5/20/20.
! This subroutine calculates the roots of a quadratic
! equation with ability to generate complex roots.

subroutine quadratic_equation_solver(a, b, c)
    ! declaring variables
    real :: a, b, c, two_a, x_1, x_2, sgn_b, disc
    complex :: z_1, z_2
    ! calculating the discriminant
    disc = b ** 2 - 4.0 * a * c
    two_a = 2.0 * a
    if (b > 0.0) sgn_b = 1.0
    if (b == 0.0) sgn_b = 0.0
    if (b < 0.0) sgn_b = -1.0
    if (disc >= 0.0) then
        x_1 = (-b - sgn_b * sqrt(disc)) / two_a
        x_2 = c / a * x_1
        print *,"Real Solution, Roots Are:", x_1, x_2
    else
        z_1 = (-b + csqrt(cmplx(disc, 0.0))) / two_a
        z_2 = c / a * z_1
        print *,"complex Solution, Roots Are:", z_1, z_2
    end if
end subroutine quadratic_equation_solver


!     file thstcyl.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     program to illustrate the use of hstcyl to solve the equation
!
!    (1/r)(d/dr)(r*du/dr) + (d/dz)(du/dz) = (2*r*z)**2*(4*z**2 + 3*r**2)
!
!     on the rectangle 0 < r < 1 , 0 < z < 1 with the
!     boundary conditions
!
!     (du/dr)(1, z) = 4*z**2  for  0 <= z <= 1
!
!     and
!
!     (du/dz)(r, 0) = 0 and (du/dz)(r, 1) = 4*r**2  for  0 <= r <= 1 .
!
!     the solution to this problem is not unique.  it is a
!     one-parameter family of solutions given by
!
!            u(r, z) = (r*z)**4 + arbitrary constant .
!
!     the r-interval will contain 50 unknowns and the z-interval will
!     contain 52 unknowns.
!
program test_hstcyl

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use fishpack

    ! Explicit typing only
    implicit none

    !-----------------------------------------------
    ! Dictionary
    !-----------------------------------------------
    integer(ip), parameter :: M = 50
    integer(ip), parameter :: N = 52
    integer(ip), parameter :: IDIMF = M + 1
    integer(ip)            :: mbdcnd, nbdcnd, i, j, ierror
    real(wp)               :: f(IDIMF,N), pertrb
    real(wp), dimension(N) :: bdb, z
    real(wp), dimension(M) :: bdc, bdd, r
    real(wp)               :: a, b, c, d, elmbda, bda(1)
    real(wp), parameter    :: ZERO = 0.0_wp, HALF = 0.5_wp
    real(wp), parameter    :: ONE = 1.0_wp, FOUR = 4.0_wp
    !-----------------------------------------------

    ! Set domain
    a = ZERO
    b = ONE
    c = ZERO
    d = ONE

    ! Set boundary conditions
    mbdcnd = 6
    nbdcnd = 3

    ! Set helmholtz constant
    elmbda = ZERO

    ! Generate and store grid points for the purpose of computing
    ! boundary data and the right side of the poisson equation.
    do i = 1, M
        r(i) = (real(i, kind=wp) - HALF)/M
    end do

    do j = 1, N
        z(j) = (real(j, kind=wp) - HALF)/N
    end do

    ! Generate boundary data. bda is a 1-dimensional dummy variable
    bdb = FOUR * (z**4)
    bdc = ZERO
    bdd = FOUR * (r**4)

    ! Generate right side of equation.
    block
        real(wp), parameter :: THREE = 3.0_wp

        do i = 1, M
            f(i,:N) = FOUR * (r(i)**2) * (z**2) * (FOUR * (z**2) + THREE * (r(i)**2) )
        end do
    end block

    ! Solve 2D Helmholtz in cylindrical coordinates on staggered grid
    call hstcyl(a, b, M, mbdcnd, bda, bdb, c, d, N, nbdcnd, bdc, bdd, &
        elmbda, f, IDIMF, pertrb, ierror)

    ! Compute discretization error by minimizing over all a the function
    ! norm(f(i, j) - a*1 - u(r(i), z(j))). The exact solution is
    !
    ! u(r, z) = (r*z)**4 + arbitrary constant.
    block
        real(wp), parameter :: KNOWN_PERTRB = -0.443113920336705e-3_wp
        real(wp), parameter :: KNOWN_ERROR = 0.752796331450795e-4_wp
        real(wp) :: x, discretization_error
        real(wp) :: exact_solution(M,N)

        x = ZERO
        do i = 1, M
            x = x + sum(f(i,:)-(r(i)*z)**4)
        end do
        x = x/(M*N)
        f(:M,:) = f(:M,:) - x

        do j = 1, N
            do i = 1, M
                exact_solution(i,j) = (r(i)*z(j))**4
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:M,:N)))

        call check_output('hstcyl', &
            ierror, KNOWN_ERROR, discretization_error, KNOWN_PERTRB, pertrb)
    end block

end program test_hstcyl


c     # ------------------------------------------------
c     # Great circle distance on sphere
c     # ------------------------------------------------
      double precision function get_gc_distance(x,y,z,w)
      implicit none

      double precision x,y,z,w(3)
      double precision p(3), pn, wn, ca, th, rsphere
      integer m

      rsphere = 1.0

      p(1) = x
      p(2) = y
      p(3) = z
      pn = sqrt(p(1)*p(1) + p(2)*p(2) + p(3)*p(3))
      if (abs(pn - rsphere) .ge. 1e-3) then
         write(6,*) 'get_gc_distance : Point is not on the sphere; '
         write(6,*) x, y, z, abs(pn-rsphere)
         stop
      endif

      wn = sqrt(w(1)*w(1) + w(2)*w(2) + w(3)*w(3))
      do m = 1,3
         w(m) = w(m)/wn
      enddo
      ca = (w(1)*x + w(2)*y + w(3)*z)/pn
      if (abs(ca) .gt. 1) then
         write(6,*) 'get_gc_distance : abs(ca) > 1; ', ca
         write(6,*) w(1), w(2), w(3), x,y,z
         stop
      endif
      th = acos(ca)
      get_gc_distance = th*rsphere

      end


subroutine get_cdf(cdf,x_vals,y_vals,ndim)
  !-------------------------------------------------
  !given x&y values returns (CDF)
  !uses trapezoidal integration
  !-------------------------------------------------
  implicit none

  integer, intent(in):: ndim
  real*8, intent(in):: x_vals(ndim),y_vals(ndim)
  real*8, intent(inout):: cdf(ndim)
  integer :: i

  !initialise each array
  cdf=0.d0

  !numerical integration to produce cumulative distribution
  do i=1,ndim-1
     cdf(i+1)= cdf(i) + 0.5*( y_vals(i+1) + y_vals(i) ) * ( x_vals(i+1) - x_vals(i) )
  enddo

  !normalise cumulative distribution to get cdf
  cdf=cdf/cdf(ndim)

  return
end subroutine get_cdf


subroutine qshep3 ( n, x, y, z, f, nq, nw, nr, lcell, lnext, xyzmin, &
  xyzdel, rmax, rsq, a, ier )

!***********************************************************************
!
!! QSHEP3 defines a smooth trivariate interpolant of scattered 3D data.
!
!  Discussion:
!
!    This subroutine computes a set of parameters A and RSQ
!    defining a smooth (once continuously differentiable) trivariate
!    function Q(X,Y,Z) which interpolates data values
!    F at scattered nodes (X,Y,Z).  The interpolant Q may be
!    evaluated at an arbitrary point by function QS3VAL, and
!    its first derivatives are computed by subroutine QS3GRD.
!
!    The interpolation scheme is a modified quadratic Shepard
!    method --
!
!      Q = (W(1)*Q(1)+W(2)*Q(2)+..+W(N)*Q(N))/(W(1)+W(2)+..+W(N))
!
!    for trivariate functions W(K) and Q(K).  The nodal functions are
!    given by
!
!      Q(K)(X,Y,Z) =
!          A(1,K) * DX**2
!        + A(2,K) * DX * DY
!        + A(3,K) * DY**2
!        + A(4,K) * DX * DZ
!        + A(5,K) * DY * DZ
!        + A(6,K) * DZ**2
!        + A(7,K) * DX
!        + A(8,K) * DY
!        + A(9,K) * DZ
!        + F(K)
!
!    where DX = (X-X(K)), DY = (Y-Y(K)), and DZ = (Z-Z(K)).
!
!    Thus, Q(K) is a quadratic function which interpolates the
!    data value at node K.  Its coefficients A(*,K) are obtained
!    by a weighted least squares fit to the closest NQ data
!    points with weights similar to W(K).  Note that the radius
!    of influence for the least squares fit is fixed for each
!    K, but varies with K.
!
!    The weights are taken to be
!
!      W(K)(X,Y,Z) = ( (R(K)-D(K))+ / R(K)*D(K) )**2
!
!    where (R(K)-D(K))+ = 0 if R(K) <= D(K), and D(K)(X,Y,Z)
!    is the euclidean distance between (X,Y,Z) and node K.  The
!    radius of influence R(K) varies with K and is chosen so
!    that NW nodes are within the radius.  Note that W(K) is
!    not defined at node (X(K),Y(K),Z(K)), but Q(X,Y,Z) has
!    limit F(K) as (X,Y,Z) approaches (X(K),Y(K),Z(K)).
!
!  Author:
!
!    Robert Renka,
!    University of North Texas,
!    (817) 565-2767.
!
!  Parameters:
!
!    Input, integer N, the number of nodes and associated data values.
!    10 <= N.
!
!    Input, real ( kind = 8 ) X(N), Y(N), Z(N), the coordinates of the nodes.
!
!    Input, real ( kind = 8 ) F(N), the data values at the nodes.
!
!    Input, integer NQ, the number of data points to be used in the least
!    squares fit for coefficients defining the nodal functions Q(K).
!    A recommended value is NQ = 17.  9 <= NQ <= MIN ( 40, N-1 ).
!
!    Input, integer NW, the number of nodes within (and defining) the radii
!    of influence R(K) which enter into the weights W(K).  For N sufficiently
!    large, a recommended value is NW = 32.  1 <= NW <= min(40,N-1).
!
!    Input, integer NR, the number of rows, columns, and planes in the cell
!    grid defined in subroutine store3.  a box containing the nodes is
!    partitioned into cells in order to increase search efficiency.
!    nr = (n/3)**(1/3) is recommended.  1 <= NR.
!
!    Output, integer LCELL(NR,NR,NR), nodal indices
!    associated with cells.  refer to store3.
!
!    Output, integer LNEXT(N), next-node indices.  refer to store3.
!
!    Output, real ( kind = 8 ) xyzmin(3), xyzdel(3), containing
!    minimum nodal coordinates and cell dim-
!    ensions, respectively.  refer to
!    store3.
!
!    Output, rmax = square root of the largest element in rsq --
!    maximum radius r(k).
!
!    Output, real ( kind = 8 ) RSQ(N) = the squares of the radii r(k)
!    which enter into the weights w(k).
!
!    Output, real ( kind = 8 ) A(9,N), the coefficients for
!    quadratic nodal function q(k) in column k.
!
!    Output, integer IER, error indicator.
!    0, if no errors were encountered.
!    1, if n, nq, nw, or nr is out of range.
!    2, if duplicate nodes were encountered.
!    3, if all nodes are coplanar.
!
!  Local parameters:
!
! av =         root-mean-square distance between k and the
!     nodes in the least squares system (unless
!     additional nodes are introduced for stabil-
!     ity).  the first 6 columns of the matrix
!     are scaled by 1/avsq, the last 3 by 1/av
! avsq =       av*av
! b =         transpose of the augmented regression matrix
! c =         first component of the plane rotation used to
!     zero the lower triangle of b**t -- computed
!     by subroutine qshep_givens
! dmin =       minimum of the magnitudes of the diagonal
!     elements of the regression matrix after
!     zeros are introduced below the diagonal
! dtol =       tolerance for detecting an ill-conditioned
!     system.  the system is accepted when DTOL <= DMIN.
! fk =         data value at node k -- f(k)
! i =         index for a, b, npts, xyzmin, xyzmn, xyzdel,
!     and xyzdl
! ib =         do-loop index for back solve
! ierr =       error flag for the call to store3
! ip1 =        i+1
! irm1 =       irow-1
! irow =       row index for b
! j =         index for a and b
! jp1 =        j+1
! k =         nodal function index and column index for a
! lmax =       maximum number of npts elements (must be con-
!     sistent with the dimension statement above)
! lnp =        current length of npts
! neq =        number of equations in the least squares fit
! nn,nnq,nnr = local copies of n, nq, and nr
! nnw =        local copy of nw
! np =         npts element
! npts =       array containing the indices of a sequence of
!     nodes to be used in the least squares fit
!     or to compute rsq.  the nodes are ordered
!     by distance from k and the last element
!     (usually indexed by lnp) is used only to
!     determine rq, or rsq(k) if NQ < NW.
! nqwmax =     max(nq,nw)
! rq =         radius of influence which enters into the
!     weights for q(k) (see subroutine setup3)
! rs =         squared distance between k and npts(lnp) --
!     used to compute rq and rsq(k)
! rsmx =       maximum rsq element encountered
! rsold =      squared distance between k and npts(lnp-1) --
!     used to compute a relative change in rs
!     between succeeding npts elements
! rtol =       tolerance for detecting a sufficiently large
!     relative change in rs.  if the change is
!     not greater than rtol, the nodes are
!     treated as being the same distance from k
! rws =        current value of rsq(k)
! s =         second component of the plane givens rotation
! sf =         marquardt stabilization factor used to damp
!     out the first 6 solution components (second
!     partials of the quadratic) when the system
!     is ill-conditioned.  as sf increases, the
!     fitting function approaches a linear
! sum2 =        sum of squared euclidean distances between
!     node k and the nodes used in the least
!     squares fit (unless additional nodes are
!     added for stability)
! t =         temporary variable for accumulating a scalar
!     product in the back solve
! xk,yk,zk =   coordinates of node k -- x(k), y(k), z(k)
! xyzdl =      local variables for xyzdel
! xyzmn =      local variables for xyzmin
!
  implicit none
!
  integer n
  integer nr
!
  real ( kind = 8 ) a(9,n)
  real ( kind = 8 ) av
  real ( kind = 8 ) avsq
  real ( kind = 8 ) b(10,10)
  real ( kind = 8 ) c
  real ( kind = 8 ) dmin
  real ( kind = 8 ), parameter :: dtol = 0.01D+00
  real ( kind = 8 ) f(n)
  real ( kind = 8 ) fk
  integer i
  integer ib
  integer ier
  integer ierr
  integer ip1
  integer irm1
  integer irow
  integer j
  integer jp1
  integer k
  integer lcell(nr,nr,nr)
  integer lmax
  integer lnext(n)
  integer lnp
  integer neq
  integer nn
  integer nnq
  integer nnr
  integer nnw
  integer np
  integer npts(40)
  integer nq
  integer nqwmax
  integer nw
  real ( kind = 8 ) rmax
  real ( kind = 8 ) rq
  real ( kind = 8 ) rs
  real ( kind = 8 ) rsmx
  real ( kind = 8 ) rsold
  real ( kind = 8 ) rsq(n)
  real ( kind = 8 ), parameter :: rtol = 1.0E-05
  real ( kind = 8 ) rws
  real ( kind = 8 ) s
  real ( kind = 8 ), parameter :: sf = 1.0D+00
  real ( kind = 8 ) sum2
  real ( kind = 8 ) t
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) xk
  real ( kind = 8 ) xyzdel(3)
  real ( kind = 8 ) xyzdl(3)
  real ( kind = 8 ) xyzmin(3)
  real ( kind = 8 ) xyzmn(3)
  real ( kind = 8 ) y(n)
  real ( kind = 8 ) yk
  real ( kind = 8 ) z(n)
  real ( kind = 8 ) zk
!
  nn = n
  nnq = nq
  nnw = nw
  nnr = nr
  nqwmax = max ( nnq, nnw )
  lmax = min ( 40, nn - 1 )

  if ( nnq < 9 ) then
    ier = 1
    return
  end if

  if ( nnw < 1 ) then
    ier = 1
    return
  end if

  if ( lmax < nqwmax ) then
    ier = 1
    return
  end if

  if ( nnr < 1 ) then
    ier = 1
    return
  end if
!
!  Create the cell data structure, and initialize RSMX.
!
  call store3 ( nn, x, y, z, nnr, lcell, lnext, xyzmn, xyzdl, ierr )

  if ( ierr /= 0 ) then
    xyzmin(1:3) = xyzmn(1:3)
    xyzdel(1:3) = xyzdl(1:3)
    ier = 3
    return
  end if

  rsmx = 0.0D+00
!
!  Outer loop on node K.
!

  do k = 1, nn

    xk = x(k)
    yk = y(k)
    zk = z(k)
    fk = f(k)
!
!  Mark node K to exclude it from the search for nearest neighbors.
!
    lnext(k) = -lnext(k)
!
!  Initialize for loop on NPTS.
!
    rs = 0.0D+00
    sum2 = 0.0D+00
    rws = 0.0D+00
    rq = 0.0D+00
    lnp = 0
!
!  Compute NPTS, LNP, rws, neq, rq, and avsq.
!
1   continue

    sum2 = sum2 + rs

    if ( lnp == lmax ) then
      go to 3
    end if

    lnp = lnp + 1
    rsold = rs
    call getnp3 ( xk, yk, zk, x, y, z, nnr, lcell, lnext, xyzmn, xyzdl, np, rs )

    if ( rs == 0.0D+00 ) then
      go to 21
    end if

    npts(lnp) = np

    if ( ( rs - rsold ) / rs < rtol ) then
      go to 1
    end if

    if ( rws == 0.0D+00 .and. nnw < lnp ) then
      rws = rs
    end if

    if ( rq /= 0.0D+00 .or. lnp <= nnq ) then
      go to 2
    end if
!
!  RQ = 0 (not yet computed) and NQ < LNP.  rq =
!  sqrt(rs) is sufficiently large to (strictly) include
!  nq nodes.  The least squares fit will include neq =
!  lnp-1 equations for 9 <= nq <= neq < lmax <= n-1.
!
    neq = lnp - 1
    rq = sqrt ( rs )
    avsq = sum2 / real ( neq, kind = 8 )
!
!  Bottom of loop -- test for termination.
!
2   continue

    if ( nqwmax < lnp ) then
      go to 4
    else
      go to 1
    end if
!
!  All LMAX nodes are included in npts.  rws and/or rq**2 is
!  (arbitrarily) taken to be 10 percent larger than the
!  distance RS to the last node included.
!
3   continue

    if ( rws == 0.0D+00 ) then
      rws = 1.1D+00 * rs
    end if

    if ( rq == 0.0D+00 ) then
      neq = lmax
      rq = sqrt ( 1.1D+00 * rs )
      avsq = sum2 / real ( neq,  kind = 8 )
    end if
!
!  Store RSQ(K), update RSMX if necessary, and compute av.
!
4   continue

    rsq(k) = rws
    rsmx = max ( rsmx, rs )
    av = sqrt ( avsq )
!
!  Set up the augmented regression matrix (transposed) as the
!  columns of B, and zero out the lower triangle (upper
!  triangle of b) with givens rotations -- qr decomposition
!  with orthogonal matrix q not stored.
!
    i = 0

5   continue

    i = i + 1
    np = npts(i)
    irow = min ( i, 10 )
    call setup3 ( xk, yk, zk, fk, x(np), y(np), z(np), f(np), av, avsq, &
      rq, b(1,irow) )

    if ( i == 1 ) then
      go to 5
    end if

    irm1 = irow-1

    do j = 1, irow-1
      jp1 = j + 1
      call qshep_givens ( b(j,j), b(j,irow), c, s )
      call rotate ( 10-j, c, s, b(jp1,j), b(jp1,irow) )
    end do

    if ( i < neq ) then
      go to 5
    end if
!
!  Test the system for ill-conditioning.
!
    dmin = min ( abs(b(1,1)), abs(b(2,2)), abs(b(3,3)), &
               abs(b(4,4)), abs(b(5,5)), abs(b(6,6)), &
               abs(b(7,7)), abs(b(8,8)), abs(b(9,9)) )

    if ( dtol <= dmin * rq ) then
      go to 13
    end if

    if ( neq == lmax ) then
      go to 10
    end if
!
!  Increase RQ and add another equation to the system to
!  improve the conditioning.  The number of NPTS elements
!  is also increased if necessary.
!
7   continue

    rsold = rs
    neq = neq + 1
    if ( neq == lmax ) go to 9
    if ( neq == lnp ) go to 8
!
!  NEQ < LNP
!
    np = npts(neq+1)
    rs = (x(np)-xk)**2 + (y(np)-yk)**2 + (z(np)-zk)**2
    if ( ( rs - rsold ) / rs < rtol ) go to 7
    rq = sqrt ( rs )
    go to 5
!
!  Add an element to NPTS.
!
8   continue

    lnp = lnp + 1
    call getnp3 (xk,yk,zk,x,y,z,nnr,lcell,lnext,xyzmn,xyzdl, np,rs)
    if ( np == 0 ) go to 21
    npts(lnp) = np
    if ( ( rs - rsold ) / rs < rtol ) go to 7
    rq = sqrt ( rs )
    go to 5

9   continue

    rq = sqrt ( 1.1D+00 * rs )
    go to 5
!
!  Stabilize the system by damping second partials.  Add
!  multiples of the first six unit vectors to the first
!  six equations.
!
10  continue

    do i = 1, 6

      b(i,10) = sf
      ip1 = i + 1

      do j = ip1, 10
        b(j,10) = 0.0D+00
      end do

      do j = i, 9
        jp1 = j + 1
        call qshep_givens (b(j,j),b(j,10),c,s)
        call rotate ( 10-j, c, s, b(jp1,j), b(jp1,10) )
      end do

    end do
!
!  Test the stabilized system for ill-conditioning.
!
    dmin = min ( abs(b(1,1)),abs(b(2,2)),abs(b(3,3)), &
               abs(b(4,4)),abs(b(5,5)),abs(b(6,6)), &
               abs(b(7,7)),abs(b(8,8)),abs(b(9,9)) )

    if ( dmin * rq < dtol ) then
      go to 22
    end if
!
!  Solve the 9 by 9 triangular system for the coefficients
!
13  continue

    do ib = 1, 9
      i = 10-ib
      t = 0.0D+00
      do j = i+1, 9
        t = t + b(j,i)*a(j,k)
      end do
      a(i,k) = (b(10,i)-t)/b(i,i)
    end do
!
!  Scale the coefficients to adjust for the column scaling.
!
    a(1:6,k) = a(1:6,k) / avsq
    a(7,k) = a(7,k) / av
    a(8,k) = a(8,k) / av
    a(9,k) = a(9,k) / av
!
!  Unmark K and the elements of NPTS.
!
    lnext(k) = -lnext(k)
    do i = 1, lnp
      np = npts(i)
      lnext(np) = -lnext(np)
    end do

  end do
!
!  No errors encountered.
!
  xyzmin(1:3) = xyzmn(1:3)
  xyzdel(1:3) = xyzdl(1:3)
  rmax = sqrt ( rsmx )
  ier = 0
  return
!
!  N, NQ, NW, or NR is out of range.
!
20 continue

  ier = 1
  return
!
!  Duplicate nodes were encountered by GETNP3.
!
21 ier = 2
  return
!
!  No unique solution due to collinear nodes.
!
22 continue

  xyzmin(1:3) = xyzmn(1:3)
  xyzdel(1:3) = xyzdl(1:3)

  ier = 3
  return
end
function qs3val ( px, py, pz, n, x, y, z, f, nr, lcell, lnext, xyzmin, &
  xyzdel, rmax, rsq, a )

!***********************************************************************
!
!! QS3VAL evaluates the interpolant function Q(X,Y,Z) created by QSHEP3.
!
!  Discussion:
!
!    This function returns the value Q(PX,PY,PZ) where Q is
!    the weighted sum of quadratic nodal functions defined in
!    subroutine QSHEP3.  QS3GRD may be called to compute a
!    gradient of Q along with the value, or to test for errors.
!
!    This function should not be called if a nonzero error flag was
!    returned by QSHEP3.
!
!  Author:
!
!    Robert Renka,
!    University of North Texas,
!    (817) 565-2767.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) PX, PY, PZ, the point P at which Q is
!    to be evaluated.
!
!    Input, integer N, the number of nodes and data values defining Q.
!    10 <= N.
!
!    Input, real ( kind = 8 ) X(N), Y(N), Z(N), F(N), the node coordinates
!    and data values interpolated by Q.
!
!    Input, integer NR, the number of rows, columns and planes in the cell
!    grid.  Refer to STORE3.  1 <= NR.
!
!    Input, integer LCELL(NR,NR,NR), nodal indices associated with cells.
!    Refer to STORE3.
!
!    Input, integer LNEXT(N), the next-node indices.  Refer to STORE3.
!
!    Input, real ( kind = 8 ) XYZMIN(3), XYZDEL(3), the minimum nodal
!    coordinates and cell dimensions, respectively.  XYZDEL elements
!    must be positive.  Refer to STORE3.
!
!    Input, real ( kind = 8 ) RMAX, the square root of the largest
!    element in RSQ, the maximum radius.
!
!    Input, real ( kind = 8 ) RSQ(N), the squared radii which enter
!    into the weights defining Q.
!
!    Input, real ( kind = 8 ) A(9,N), the coefficients for the nodal
!    functions defining Q.
!
!    Output, real ( kind = 8 ) QS3VAL, the function value Q(PX,PY,PZ)
!    unless N, NR, XYZDEL, or RMAX is invalid, in which case the
!    value 0 is returned.
!
  implicit none
!
  integer n
  integer nr
!
  real ( kind = 8 ) a(9,n)
  real ( kind = 8 ) delx
  real ( kind = 8 ) dely
  real ( kind = 8 ) delz
  real ( kind = 8 ) dxsq
  real ( kind = 8 ) dysq
  real ( kind = 8 ) dzsq
  real ( kind = 8 ) ds
  real ( kind = 8 ) dx
  real ( kind = 8 ) dy
  real ( kind = 8 ) dz
  real ( kind = 8 ) f(n)
  integer i
  integer imax
  integer imin
  integer j
  integer jmax
  integer jmin
  integer k
  integer kmax
  integer kmin
  integer l
  integer lcell(nr,nr,nr)
  integer lnext(n)
  integer lp
  real ( kind = 8 ) px
  real ( kind = 8 ) py
  real ( kind = 8 ) pz
  real ( kind = 8 ) qs3val
  real ( kind = 8 ) rd
  real ( kind = 8 ) rds
  real ( kind = 8 ) rmax
  real ( kind = 8 ) rs
  real ( kind = 8 ) rsq(n)
  real ( kind = 8 ) sw
  real ( kind = 8 ) swq
  real ( kind = 8 ) w
  real ( kind = 8 ) x(n)
!  real ( kind = 8 ) xmax
  real ( kind = 8 ) xmin
  real ( kind = 8 ) xp
  real ( kind = 8 ) xyzdel(3)
  real ( kind = 8 ) xyzmin(3)
  real ( kind = 8 ) y(n)
!  real ( kind = 8 ) ymax
  real ( kind = 8 ) ymin
  real ( kind = 8 ) yp
  real ( kind = 8 ) z(n)
!  real ( kind = 8 ) zmax
  real ( kind = 8 ) zmin
  real ( kind = 8 ) zp
!
  xp = px
  yp = py
  zp = pz
  xmin = xyzmin(1)
  ymin = xyzmin(2)
  zmin = xyzmin(3)
  dx = xyzdel(1)
  dy = xyzdel(2)
  dz = xyzdel(3)

  if ( n < 10 ) then
    qs3val = 0.0D+00
    return
  end if

  if ( nr < 1  .or.  dx <= 0.0 &
         .or.  dy <= 0.0  .or.  dz <= 0.0  .or. &
         rmax < 0.0 ) then
    qs3val = 0.0D+00
    return
  end if
!
!  Set IMIN, imax, jmin, jmax, kmin, and kmax to cell indices
!  defining the range of the search for nodes whose radii
!  include P.  The cells which must be searched are those
!  intersected by (or contained in) a sphere of radius rmax
!  centered at P.
!
  imin = int((xp-xmin-rmax)/dx) + 1
  imin = max ( imin, 1 )

  imax = int((xp-xmin+rmax)/dx) + 1
  imax = min ( imax, nr )

  jmin = int((yp-ymin-rmax)/dy) + 1
  jmin = max ( jmin, 1 )

  jmax = int((yp-ymin+rmax)/dy) + 1
  jmax = min ( jmax, nr )

  kmin = int((zp-zmin-rmax)/dz) + 1
  kmin = max ( kmin, 1 )

  kmax = int((zp-zmin+rmax)/dz) + 1
  kmax = min ( kmax, nr )
!
!  Test for no cells within the sphere of radius RMAX.
!
  if ( imax < imax .or. &
       jmax < jmin .or. &
       kmax < kmin ) then
    qs3val = 0.0D+00
    return
  end if
!
!  Accumulate weight values in SW and weighted nodal function
!  values in SWQ.  The weights are w(l) = ((r-d)+/(r*d))**2
!  for r**2 = rsq(l) and d = distance between P and node L.
!
  sw = 0.0D+00
  swq = 0.0D+00
!
!  Outer loop on cells (i,j,k).
!
  do k = kmin, kmax
    do j = jmin, jmax
      do i = imin, imax

        l = lcell(i,j,k)

        if ( l == 0 ) then
          cycle
        end if
!
!  Inner loop on nodes L.
!
        do

          delx = xp - x(l)
          dely = yp - y(l)
          delz = zp - z(l)

          dxsq = delx * delx
          dysq = dely * dely
          dzsq = delz * delz

          ds = dxsq + dysq + dzsq
          rs = rsq(l)

          if ( ds < rs ) then

            if ( ds == 0.0D+00 ) then
              qs3val = f(l)
              return
            end if

            rds = rs * ds
            rd = sqrt ( rds )
            w = ( rs + ds - rd - rd ) / rds
            sw = sw + w

            swq = swq + w *( a(1,l) * dxsq + a(2,l)*delx*dely + &
              a(3,l) * dysq + a(4,l)*delx*delz + &
              a(5,l) * dely*delz + a(6,l)*dzsq + &
              a(7,l) * delx + a(8,l)*dely + &
              a(9,l) * delz + f(l) )

          end if

          lp = l
          l = lnext(lp)

          if ( l == lp ) then
            exit
          end if

        end do

      end do
    end do
  end do
!
!  SW = 0 iff P is not within the radius R(L) for any node L.
!
  if ( sw == 0.0D+00 ) then
    qs3val = 0.0D+00
  else
    qs3val = swq / sw
  end if

  return
end
subroutine qs3grd ( px, py, pz, n, x, y, z, f, nr, lcell, lnext, xyzmin, &
  xyzdel, rmax, rsq, a, q, qx, qy, qz, ier )

!***********************************************************************
!
!! QS3GRD computes the value and gradient of the interpolant function.
!
!  Discussion:
!
!    This subroutine computes the value and gradient at (PX,PY,PZ) of
!    the interpolatory function Q defined in subroutine QSHEP3.
!
!    Q(X,Y,Z) is a weighted sum of quadratic nodal functions.
!
!  Author:
!
!    Robert Renka,
!    University of North Texas,
!    (817) 565-2767.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) PX, PY, PZ, the point P at which Q and
!    its partials are to be evaluated.
!
!    Input, integer N, the number of nodes and data values defining Q.
!    10 <= N.
!
!    Input, real ( kind = 8 ) X(N), Y(N), Z(N), F(N), the node coordinates and
!    data values interpolated by Q.
!
!    Input, integer NR, the number of rows, columns and planes in the cell
!    grid.  Refer to STORE3.  1 <= NR.
!
!    Input, integer LCELL(NR,NR,NR), nodal indices associated with cells.
!    Refer to STORE3.
!
!    Input, integer LNEXT(N), the next-node indices.  Refer to STORE3.
!
!    Input, real ( kind = 8 ) XYZMIN(3), XYZDEL(3), the minimum nodal
!    coordinates and cell dimensions, respectively.  XYZDEL elements must
!    be positive.  Refer to STORE3.
!
!    Input, real ( kind = 8 ) RMAX, the square root of the largest element
!    in RSQ, the maximum radius.
!
!    Input, real ( kind = 8 ) RSQ(N), the squared radii which enter into
!    the weights defining Q.
!
!    Input, real ( kind = 8 ) A(9,N), the coefficients for the nodal
!    functions defining Q.
!
!    Output, real ( kind = 8 ) Q, the value of Q at (PX,PY,PZ) unless
!    IER == 1, in which case no values are returned.
!
!    Output, real ( kind = 8 ) QX, QY, QZ, the first partial derivatives of Q at
!    (PX,PY,PZ) unless IER == 1.
!
!    Output, integer IER, error indicator
!    0, if no errors were encountered.
!    1, if N, NR, XYZDEL, or RMAX is invalid.
!    2, if no errors were encountered but (PX.PY.PZ) is not within the
!       radius R(K) for any node K (and thus Q = QX = QY = QZ = 0).
!
  implicit none
!
  integer n
  integer nr
!
  real ( kind = 8 ) a(9,n)
  real ( kind = 8 ) delx
  real ( kind = 8 ) dely
  real ( kind = 8 ) delz
  real ( kind = 8 ) ds
  real ( kind = 8 ) dx
  real ( kind = 8 ) dxsq
  real ( kind = 8 ) dy
  real ( kind = 8 ) dysq
  real ( kind = 8 ) dz
  real ( kind = 8 ) dzsq
  real ( kind = 8 ) f(n)
  integer i
  integer ier
  integer imax
  integer imin
  integer j
  integer jmax
  integer jmin
  integer k
  integer kmax
  integer kmin
  integer l
  integer lcell(nr,nr,nr)
  integer lnext(n)
  integer lp
  real ( kind = 8 ) px
  real ( kind = 8 ) py
  real ( kind = 8 ) pz
  real ( kind = 8 ) q
  real ( kind = 8 ) ql
  real ( kind = 8 ) qlx
  real ( kind = 8 ) qly
  real ( kind = 8 ) qlz
  real ( kind = 8 ) qx
  real ( kind = 8 ) qy
  real ( kind = 8 ) qz
  real ( kind = 8 ) rd
  real ( kind = 8 ) rds
  real ( kind = 8 ) rmax
  real ( kind = 8 ) rs
  real ( kind = 8 ) rsq(n)
  real ( kind = 8 ) sw
  real ( kind = 8 ) swq
  real ( kind = 8 ) swqx
  real ( kind = 8 ) swqy
  real ( kind = 8 ) swqz
  real ( kind = 8 ) sws
  real ( kind = 8 ) swx
  real ( kind = 8 ) swy
  real ( kind = 8 ) swz
  real ( kind = 8 ) t
  real ( kind = 8 ) w
  real ( kind = 8 ) wx
  real ( kind = 8 ) wy
  real ( kind = 8 ) wz
  real ( kind = 8 ) x(n)
!  real ( kind = 8 ) xmax
  real ( kind = 8 ) xmin
  real ( kind = 8 ) xp
  real ( kind = 8 ) xyzdel(3)
  real ( kind = 8 ) xyzmin(3)
  real ( kind = 8 ) y(n)
!  real ( kind = 8 ) ymax
  real ( kind = 8 ) ymin
  real ( kind = 8 ) yp
  real ( kind = 8 ) z(n)
!  real ( kind = 8 ) zmax
  real ( kind = 8 ) zmin
  real ( kind = 8 ) zp
!
  xp = px
  yp = py
  zp = pz
  xmin = xyzmin(1)
  ymin = xyzmin(2)
  zmin = xyzmin(3)
  dx = xyzdel(1)
  dy = xyzdel(2)
  dz = xyzdel(3)

  if ( n < 10  .or.  nr < 1  .or.  dx <= 0. &
         .or.  dy <= 0.0D+00  .or.  dz <= 0.0D+00  .or. &
         rmax < 0.0D+00 ) then
    ier = 1
    return
  end if
!
!  Set IMIN, imax, jmin, jmax, kmin, and kmax to cell indices
!  defining the range of the search for nodes whose radii
!  include P.  The cells which must be searched are those
!  intersected by (or contained in) a sphere of radius RMAX
!  centered at P.
!
  imin = int((xp-xmin-rmax)/dx) + 1
  imin = max ( imin, 1 )

  imax = int((xp-xmin+rmax)/dx) + 1
  imax = min ( imax, nr )

  jmin = int((yp-ymin-rmax)/dy) + 1
  jmin = max ( jmin, 1 )

  jmax = int((yp-ymin+rmax)/dy) + 1
  jmax = min ( jmax, nr )

  kmin = int((zp-zmin-rmax)/dz) + 1
  kmin = max ( kmin, 1 )

  kmax = int((zp-zmin+rmax)/dz) + 1
  kmax = min ( kmax, nr )
!
!  Test for no cells within the sphere of radius RMAX.
!
  if ( imax < imin .or. &
       jmax < jmin .or. &
       kmax < kmin ) then
    q = 0.0D+00
    qx = 0.0D+00
    qy = 0.0D+00
    qz = 0.0D+00
    ier = 2
    return
  end if
!
!  Q = swq/sw = sum(w(l)*q(l))/sum(w(l)) where the sum is
!  from l = 1 to N, q(l) is the quadratic nodal function,
!  and w(l) = ((r-d)+/(r*d))**2 for radius r(l) and dist-
!  ance d(l).  thus
!
!    qx = (swqx*sw - swq*swx) / sw**2
!    qy = (swqy*sw - swq*swy) / sw**2
!    qz = (swqz*sw - swq*swz) / sw**2
!
!  where swqx and swx are partial derivatives with respect
!  to X of swq and sw, respectively.  swqy, swy, swqz, and
!  swz are defined similarly.
!
  sw = 0.0D+00
  swx = 0.0D+00
  swy = 0.0D+00
  swz = 0.0D+00
  swq = 0.0D+00
  swqx = 0.0D+00
  swqy = 0.0D+00
  swqz = 0.0D+00
!
!  Outer loop on cells (i,j,k).
!
  do k = kmin, kmax
    do j = jmin, jmax
      do i = imin, imax

        l = lcell(i,j,k)
        if ( l == 0 ) then
          cycle
        end if
!
!  Inner loop on nodes L.
!
        do

          delx = xp - x(l)
          dely = yp - y(l)
          delz = zp - z(l)
          dxsq = delx * delx
          dysq = dely * dely
          dzsq = delz * delz
          ds = dxsq + dysq + dzsq
          rs = rsq(l)

          if ( ds < rs ) then

            if ( ds == 0.0D+00 ) then
              q = f(l)
              qx = a(7,l)
              qy = a(8,l)
              qz = a(9,l)
              ier = 0
              return
            end if

            rds = rs*ds
            rd = sqrt(rds)
            w = (rs+ds-rd-rd)/rds
            t = 2.0D+00 *(rd-rs)/(ds*rds)
            wx = delx*t
            wy = dely*t
            wz = delz*t

            qlx = 2.0D+00 *a(1,l)*delx + a(2,l)*dely + a(4,l)*delz
            qly = a(2,l)*delx + 2.0D+00 * a(3,l)*dely + a(5,l)*delz
            qlz = a(4,l)*delx + a(5,l)*dely + 2.0D+00 * a(6,l)*delz
            ql = (qlx*delx + qly*dely + qlz*delz) / 2.0D+00 + &
              a(7,l)*delx + a(8,l)*dely + a(9,l)*delz + f(l)
            qlx = qlx + a(7,l)
            qly = qly + a(8,l)
            qlz = qlz + a(9,l)

            sw = sw + w
            swx = swx + wx
            swy = swy + wy
            swz = swz + wz
            swq = swq + w*ql
            swqx = swqx + wx*ql + w*qlx
            swqy = swqy + wy*ql + w*qly
            swqz = swqz + wz*ql + w*qlz

          end if

          lp = l
          l = lnext(lp)

          if ( l == lp ) then
            exit
          end if

        end do

      end do
    end do
  end do
!
!  SW = 0 iff P is not within the radius R(L) for any node L.
!
  if ( sw /= 0.0D+00 ) then

    q = swq/sw
    sws = sw*sw
    qx = (swqx*sw - swq*swx)/sws
    qy = (swqy*sw - swq*swy)/sws
    qz = (swqz*sw - swq*swz)/sws
    ier = 0
!
!  No cells contain a point within RMAX of P, or
!  SW = 0 and thus RSQ(L) <= DS for all L.
!
  else

    q = 0.0D+00
    qx = 0.0D+00
    qy = 0.0D+00
    qz = 0.0D+00
    ier = 2

  end if

  return
end
subroutine getnp3 ( px, py, pz, x, y, z, nr, lcell, lnext, xyzmin, &
  xyzdel, np, dsq )

!***********************************************************************
!
!! GETNP3 finds the closest node to a given point.
!
!  Discussion:
!
!    Given a set of N nodes and the data structure defined in
!    subroutine STORE3, this subroutine uses the cell method to
!    find the closest unmarked node NP to a specified point P.
!
!    NP is then marked by setting LNEXT(NP) to -LNEXT(NP).  (A
!    node is marked if and only if the corresponding lnext element
!    is negative.  The absolute values of LNEXT elements,
!    however, must be preserved.)  Thus, the closest M nodes to
!    P may be determined by a sequence of M calls to this routine.
!    Note that if the nearest neighbor to node K is to
!    be determined (PX = X(K), PY = Y(K), and PZ = Z(K)), then
!    K should be marked before the call to this routine.
!
!    The search is begun in the cell containing (or closest
!    to) P and proceeds outward in box-shaped layers until all
!    cells which contain points within distance R of P have
!    been searched, where R is the distance from P to the first
!    unmarked node encountered (infinite if no unmarked nodes
!    are present).
!
!  Author:
!
!    Robert Renka,
!    University of North Texas,
!    (817) 565-2767.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) PX, PY, PZ, the coordinates of the point P
!    whose nearest unmarked neighbor is to be found.
!
!    Input, real ( kind = 8 ) X(N), Y(N), Z(N), the coordinates of the nodes.
!
!    Input, integer NR, the number of rows, columns, and planes in the cell
!    grid.  1 <= NR.
!
!    Input, integer LCELL(NR,NR,NR), nodal indices associated with cells.
!
!    Input/output, integer LNEXT(N), next-node indices (or their negatives).
!
!    Input, real ( kind = 8 ) XYZMIN(3), XYZDEL(3), minimum nodal
!    coordinates and cell dimensions, respectively.  XYZEL elements must
!    be positive.
!
!    Output, integer NP, index of the nearest unmarked node to P, or 0
!    if all nodes are marked or NR < 1 or an element of XYZDEL is not
!    positive.  LNEXT(NP) < 0 if NP /= 0.
!
!    Output, real ( kind = 8 ) DSQ, squared euclidean distance between
!    P and node NP, or 0 if NP = 0.
!
  implicit none
!
  integer nr
!
  real ( kind = 8 ) delx
  real ( kind = 8 ) dely
  real ( kind = 8 ) delz
  real ( kind = 8 ) dsq
  real ( kind = 8 ) dx
  real ( kind = 8 ) dy
  real ( kind = 8 ) dz
  logical first
  integer i
  integer i0
  integer i1
  integer i2
  integer imax
  integer imin
  integer j
  integer j0
  integer j1
  integer j2
  integer jmax
  integer jmin
  integer k
  integer k0
  integer k1
  integer k2
  integer kmax
  integer kmin
  integer l
  integer lcell(nr,nr,nr)
  integer lmin
  integer ln
  integer lnext(*)
  integer np
  real ( kind = 8 ) px
  real ( kind = 8 ) py
  real ( kind = 8 ) pz
  real ( kind = 8 ) r
  real ( kind = 8 ) rsmin
  real ( kind = 8 ) rsq
  real ( kind = 8 ) x(*)
  real ( kind = 8 ) xp
  real ( kind = 8 ) xyzdel(3)
  real ( kind = 8 ) xyzmin(3)
  real ( kind = 8 ) y(*)
  real ( kind = 8 ) yp
  real ( kind = 8 ) z(*)
  real ( kind = 8 ) zp
!
  xp = px
  yp = py
  zp = pz
  dx = xyzdel(1)
  dy = xyzdel(2)
  dz = xyzdel(3)
!
!  Test for invalid input parameters.
!
  if ( nr < 1 .or. dx <= 0.0D+00 .or. dy <= 0.0D+00 .or. dz <= 0.0D+00 ) then
    np = 0
    dsq = 0.0D+00
    return
  end if
!
!  Initialize parameters --
!
!  first = true iff the first unmarked node has yet to be encountered,
!  imin,...,kmax = cell indices defining the range of the search,
!  delx,dely,delz = px-xyzmin(1), py-xyzmin(2), and pz-xyzmin(3),
!  i0,j0,k0 = cell containing or closest to p,
!  i1,...,k2 = cell indices of the layer whose intersection
!  with the range defined by imin,...,kmax is
!  currently being searched.
!
  first = .true.
  imin = 1
  imax = nr
  jmin = 1
  jmax = nr
  kmin = 1
  kmax = nr
  delx = xp - xyzmin(1)
  dely = yp - xyzmin(2)
  delz = zp - xyzmin(3)
  i0 = int(delx/dx) + 1
  if ( i0 < 1 ) i0 = 1
  if ( nr < i0 ) then
    i0 = nr
  end if

  j0 = int ( dely / dy ) + 1
  if ( j0 < 1 ) j0 = 1
  if ( nr < j0 ) then
    j0 = nr
  end if

  k0 = int(delz/dz) + 1
  if ( k0 < 1 ) k0 = 1
  if ( nr < k0 ) then
    k0 = nr
  end if

  i1 = i0
  i2 = i0
  j1 = j0
  j2 = j0
  k1 = k0
  k2 = k0
!
!  Outer loop on layers, inner loop on layer cells, excluding
!  those outside the range (imin,imax) x (jmin,jmax) x (kmin,kmax).
!
1 continue

  do 7 k = k1, k2

    if ( kmax < k ) go to 8
    if ( k < kmin ) go to 7

    do 6 j = j1, j2

      if ( jmax < j ) go to 7
      if ( j < jmin ) go to 6

      do 5 i = i1, i2

        if ( imax < i ) go to 6
        if ( i < imin ) go to 5
        if ( k /= k1  .and.  k /= k2  .and. j /= j1  .and.  &
          j /= j2  .and. i /= i1  .and.  i /= i2) go to 5
!
!  Search cell (i,j,k) for unmarked nodes L.
!
        l = lcell(i,j,k)
        if ( l == 0 ) go to 5
!
!  Loop on nodes in cell (i,j,k).
!
2       continue

        ln = lnext(l)
        if ( ln < 0 ) go to 4
!
!  Node L is not marked.
!
        rsq = (x(l)-xp)**2 + (y(l)-yp)**2 + (z(l)-zp)**2
        if ( .not. first ) go to 3
!
!  Node L is the first unmarked neighbor of P encountered.
!  initialize LMIN to the current candidate for NP, and
!  rsmin to the squared distance from P to lmin.  imin,
!  imax, jmin, jmax, kmin, and kmax are updated to define
!  the smallest rectangle containing a sphere of radius
!  r = sqrt(rsmin) centered at P, and contained in (1,nr)
!  x (1,nr) x (1,nr) (except that, if P is outside the
!  box defined by the nodes, it is possible that NR < imin
!  or imax < 1, etc.).  FIRST is reset to
!  false.
!
  lmin = l
  rsmin = rsq
  r = sqrt(rsmin)
  imin = int((delx-r)/dx) + 1
  if ( imin < 1 ) imin = 1
  imax = int((delx+r)/dx) + 1
  if ( nr < imax ) imax = nr
  jmin = int((dely-r)/dy) + 1
  if ( jmin < 1 ) jmin = 1
  jmax = int((dely+r)/dy) + 1
  if ( nr < jmax ) jmax = nr
  kmin = int((delz-r)/dz) + 1
  if ( kmin < 1 ) kmin = 1
  kmax = int((delz+r)/dz) + 1
  if ( nr < kmax ) kmax = nr
  first = .false.
  go to 4
!
!  Test for node L closer than LMIN to P.
!
3      continue
!
!  Update LMIN and RSMIN.
!
  if ( rsq < rsmin ) then
    lmin = l
    rsmin = rsq
  end if
!
!  Test for termination of loop on nodes in cell (i,j,k).
!
4      continue

  if ( abs(ln) == l ) go to 5
  l = abs ( ln )
  go to 2

5      continue
6    continue
7  continue
!
! Test for termination of loop on cell layers.
!
8 continue

  if ( i1 <= imin .and. imax <= i2 .and. &
       j1 <= jmin .and. jmax <= j2 .and. &
       k1 <= kmin .and. kmax <= k2 ) go to 9
  i1 = i1 - 1
  i2 = i2 + 1
  j1 = j1 - 1
  j2 = j2 + 1
  k1 = k1 - 1
  k2 = k2 + 1
  go to 1
!
!  Unless no unmarked nodes were encountered, LMIN is the
!  closest unmarked node to P.
!
9 continue

  if ( .not. first ) then
    np = lmin
    dsq = rsmin
    lnext(lmin) = -lnext(lmin)
  else
    np = 0
    dsq = 0.0D+00
  end if

  return
end
!!$subroutine qshep_givens ( a, b, c, s )
!!$
!!$!***********************************************************************
!!$!
!!$!! QSHEP_GIVENS constructs a Givens plane rotation.
!!$!
!!$!  Discussion:
!!$!
!!$!    This routine constructs the Givens plane rotation
!!$!
!!$!          ( c  s)
!!$!      g = (     )
!!$!          (-s  c)
!!$!
!!$!    where c*c + s*s = 1, which zeros the second entry of the 2-vector
!!$!    (a b)-transpose.  A call to QSHEP_GIVENS is normally followed by a call
!!$!    to ROTATE which applies the transformation to a 2 by N matrix.
!!$!    This routine was taken from LINPACK.
!!$!
!!$!  Author:
!!$!
!!$!    Robert Renka,
!!$!    University of North Texas,
!!$!    (817) 565-2767.
!!$!
!!$!  Parameters:
!!$!
!!$!    Input/output, real ( kind = 8 ) A.  On input, the first component of
!!$!    the vector.  On output, overwritten by r = +/-sqrt(a*a + b*b)
!!$!
!!$!    Input/output, real ( kind = 8 ) B.  On input, the second component of
!!$!    the vector.  On output, overwritten by a value z which allows c
!!$!    and s to be recovered as follows --
!!$!    c = sqrt(1-z*z), s=z     if abs(z) <= 1.
!!$!    c = 1/z, s = sqrt(1-c*c) if 1 < abs(z).
!!$!
!!$!    Output, real ( kind = 8 ) C, c = +/-(a/r)
!!$!
!!$!    Output, real ( kind = 8 ) S, s = +/-(b/r)
!!$!
!!$!  Local parameters:
!!$!
!!$!    aa,bb = local copies of a and b
!!$!    r =    c*a + s*b = +/-sqrt(a*a+b*b)
!!$!    u,v =   variables used to scale a and b for computing r
!!$!
!!$  implicit none
!!$!
!!$  real ( kind = 8 ) a
!!$  real ( kind = 8 ) aa
!!$  real ( kind = 8 ) b
!!$  real ( kind = 8 ) bb
!!$  real ( kind = 8 ) c
!!$  real ( kind = 8 ) r
!!$  real ( kind = 8 ) s
!!$  real ( kind = 8 ) u
!!$  real ( kind = 8 ) v
!!$!
!!$  aa = a
!!$  bb = b
!!$!
!!$!  Abs(b) < abs(a)
!!$!  Note that R has the sign of A, 0 < C, and S has sign(a)*sign(b).
!!$!
!!$  if ( abs ( bb ) < abs ( aa ) ) then
!!$    u = aa + aa
!!$    v = bb / u
!!$    r = sqrt ( 0.25D+00 + v*v ) * u
!!$    c = aa / r
!!$    s = v * (c + c)
!!$    b = s
!!$    a = r
!!$    return
!!$  end if
!!$!
!!$!  abs(a) <= abs(b)
!!$!
!!$  if ( bb == 0.0D+00 ) then
!!$    c = 1.0D+00
!!$    s = 0.0D+00
!!$    return
!!$  end if
!!$
!!$  u = bb + bb
!!$  v = aa / u
!!$!
!!$!  Store R in A.
!!$!
!!$  a = sqrt ( 0.25D+00 + v*v ) * u
!!$  s = bb / a
!!$  c = v * (s + s)
!!$!
!!$!  Note that R has the sign of b, 0 < S, and c has sign(a)*sign(b).
!!$!
!!$  b = 1.0D+00
!!$  if ( c /= 0.0D+00 ) then
!!$    b = 1.0D+00 / c
!!$  end if
!!$
!!$  return
!!$end
!!$subroutine rotate ( n, c, s, x, y )
!!$
!!$!***********************************************************************
!!$!
!!$!! ROTATE applies a Givens rotation to two vectors.
!!$!
!!$!  Discussion:
!!$!
!!$!    This routine applies the Givens rotation
!!$!
!!$!      ( c  s)
!!$!      (-s  c)
!!$!
!!$!    to the 2 by n matrix
!!$!
!!$!      (x(1) ... x(n))
!!$!      (y(1) ... y(n))
!!$!
!!$!  Author:
!!$!
!!$!    Robert Renka,
!!$!    University of North Texas,
!!$!    (817) 565-2767.
!!$!
!!$!  Parameters:
!!$!
!!$!    Input, integer N, the number of columns to be rotated.
!!$!
!!$!    Input, real ( kind = 8 ) C, S, the elements of the Givens rotation.
!!$!    These may be determined by subroutine QSHEP_GIVENS.
!!$!
!!$!    Input/output, real ( kind = 8 ) X(N), Y(N), the vectors to be rotated.
!!$!
!!$  implicit none
!!$!
!!$  integer n
!!$!
!!$  real ( kind = 8 ) c
!!$  integer i
!!$  real ( kind = 8 ) s
!!$  real ( kind = 8 ) x(n)
!!$  real ( kind = 8 ) xi
!!$  real ( kind = 8 ) y(n)
!!$  real ( kind = 8 ) yi
!!$!
!!$  if ( c == 1.0D+00 .and. s == 0.0D+00 ) then
!!$    return
!!$  end if
!!$
!!$  do i = 1, n
!!$    xi = x(i)
!!$    yi = y(i)
!!$    x(i) =  c * xi + s * yi
!!$    y(i) = -s * xi + c * yi
!!$  end do
!!$
!!$  return
!!$end
subroutine setup3 ( xk, yk, zk, fk, xi, yi, zi, fi, s1, s2, r, row )

!***********************************************************************
!
!! SETUP3 sets up the weighted least-squares fit of the data.
!
!  Discussion:
!
!    This routine sets up the I-th row of an augmented regression matrix
!    for a weighted least-squares fit of a quadratic function Q(X,Y,Z)
!    to a set of data values F, where Q(XK,YK,ZK) = FK.
!
!    The first 6 columns (quadratic terms) are scaled by 1/S2, and columns
!    7, 8, and 9 (linear terms) are scaled by 1/S1.  The weight is
!    (R-D)/(R*D) if D < R, and 0 if R <= D, where D is the distance
!    between nodes I and K.
!
!  Author:
!
!    Robert Renka,
!    University of North Texas,
!    (817) 565-2767.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) XK, YK, ZK, FK = coordinates and data value
!    at node K (interpolated by q).
!
!    Input, real ( kind = 8 ) XI, YI, ZI, FI = coordinates and data value
!    at node I.
!
!    Input, real ( kind = 8 ) S1, S2 = reciprocals of the scale factors.
!
!    Input, real ( kind = 8 ) R = radius of influence about node K defining the
!    weight.
!
!    Output, real ( kind = 8 ) ROW(10), a row of the augmented
!    regression matrix.
!
!  Local parameters:
!
!    d =   distance between nodes k and i
!    w =   weight associated with the row
!    w1 =   w/s1
!    w2 =   w/s2
!
  implicit none
!
  real ( kind = 8 ) d
  real ( kind = 8 ) dx
!  real ( kind = 8 ) dxsq
  real ( kind = 8 ) dy
!  real ( kind = 8 ) dysq
  real ( kind = 8 ) dz
!  real ( kind = 8 ) dzsq
  real ( kind = 8 ) fi
  real ( kind = 8 ) fk
!  integer i
  real ( kind = 8 ) r
  real ( kind = 8 ) row(10)
  real ( kind = 8 ) s1
  real ( kind = 8 ) s2
  real ( kind = 8 ) w
  real ( kind = 8 ) w1
  real ( kind = 8 ) w2
  real ( kind = 8 ) xi
  real ( kind = 8 ) xk
  real ( kind = 8 ) yi
  real ( kind = 8 ) yk
  real ( kind = 8 ) zi
  real ( kind = 8 ) zk
!
  dx = xi - xk
  dy = yi - yk
  dz = zi - zk

  d = sqrt ( dx**2 + dy**2 + dz**2 )

  if ( d <= 0.0D+00 .or. r <= d ) then
    row(1:10) = 0.0D+00
    return
  end if

  w = ( r - d ) / r / d
  w1 = w / s1
  w2 = w / s2

  row(1) = dx * dx * w2
  row(2) = dx * dy * w2
  row(3) = dy * dy * w2
  row(4) = dx * dz * w2
  row(5) = dy * dz * w2
  row(6) = dz * dz * w2

  row(7) = dx * w1
  row(8) = dy * w1
  row(9) = dz * w1

  row(10) = ( fi - fk ) * w

  return
end
subroutine store3 ( n, x, y, z, nr, lcell, lnext, xyzmin, xyzdel, ier )

!***********************************************************************
!
!! STORE3 sets up a data structure for N scattered nodes in 3D.
!
!  Discussion:
!
!    Given a set of N arbitrarily distributed nodes in three-space,
!    this subroutine creates a data structure for a cell-based method of
!    solving closest-point problems.  The smallest box containing the nodes
!    is partitioned into an NR by NR by NR uniform grid of cells, and
!    nodes are associated with cells.  In particular, the data structure
!    stores the indices of the nodes contained in each cell.  For a
!    uniform random distribution of nodes, the nearest node to an
!    arbitrary point can be determined in constant expected time.
!
!  Author:
!
!    Robert Renka,
!    University of North Texas,
!    (817) 565-2767.
!
!  Parameters:
!
!    Input, integer N, the number of nodes.  2 <= N.
!
!    Input, real ( kind = 8 ) X(N), Y(N), Z(N), the coordinates of the nodes.
!
!    Input, integer NR, the number of rows, columns, and planes in the
!    grid.  The cell density (average number of nodes per cell) is
!    D = N/(NR**3).  A recommended value, based on empirical evidence,
!    is D = 3, so NR = (N/3)**(1/3).  1 <= NR.
!
!    Output, integer LCELL(NR,NR,NR), a cell array such that
!    lcell(i,j,k) contains the index (for x, y,
!    and z) of the first node (node with smallest
!    index) in cell (i,j,k), or lcell(i,j,k) = 0
!    if no nodes are contained in the cell.  the
!    corner of cell (i,j,k) which is farthest
!    from the box corner defined by xyzmin has
!    coordinates (xmin+i*dx,ymin+j*dy,zmin+k*dz),
!    where (xmin,ymin,zmin) are the elements of
!    xyzmin.  lcell is not defined if ier /= 0.
!
!    Output, integer LNEXT(N),  next-node indices such that
!    lnext(l) contains the index of the next node
!    in the cell which contains node l, or
!    lnext(l) = l if l is the last node in the
!    cell for l = 1,...,n.  (the nodes contained
!    in a cell are ordered by their indices.)
!    if, for example, cell (i,j,k) contains nodes
!    2, 3, and 5 (and no others), then
!    lcell(i,j,k) = 2, lnext(2) = 3, lnext(3) =
!    5, and lnext(5) = 5.  lnext is not defined
!    if ier /= 0.
!
!    Output, real ( kind = 8 ) XYZMIN(3), the minimum
!    nodal coordinates xmin, ymin, and zmin (in
!    that order) unless ier = 1.  the opposite
!    corner of the box defined by the nodes is
!    (xmin+nr*dx,ymin+nr*dy,zmin+nr*dz).
!
!    Output, real ( kind = 8 ) XYZDEL(3), the dimensions
!    of the cells unless ier = 1.  xyzdel(1) =
!    (xmax-xmin)/nr, xyzdel(2) = (ymax-ymin)/nr,
!    and xyzdel(3) = (zmax-zmin)/nr, where xmin,
!    xmax, ymin, ymax, zmin, and zmax are the
!    extrema of x, y, and z.
!
!    Output, integer IER,  = error indicator --
!    0, if no errors were encountered.
!    1, if n < 2 or nr < 1.
!    2, if a component of xyzdel is not positive.
!
  implicit none
!
  integer n
  integer nr
!
  real ( kind = 8 ) delx
  real ( kind = 8 ) dely
  real ( kind = 8 ) delz
  integer i
  integer ier
  integer j
  integer k
  integer l
  integer lb
  integer lcell(nr,nr,nr)
  integer ll
  integer lnext(n)
  integer nn
  integer nnr
  integer np1
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) xmn
  real ( kind = 8 ) xmx
  real ( kind = 8 ) xyzdel(3)
  real ( kind = 8 ) xyzmin(3)
  real ( kind = 8 ) y(n)
  real ( kind = 8 ) ymx
  real ( kind = 8 ) ymn
  real ( kind = 8 ) z(n)
  real ( kind = 8 ) zmx
  real ( kind = 8 ) zmn
!
  ier = 0
  nn = n
  nnr = nr

  if ( nn < 2 .or. nnr < 1 ) then
    ier = 1
    return
  end if
!
!  Compute the dimensions of the box containing the nodes.
!
  xmn = minval ( x(1:nn) )
  xmx = maxval ( x(1:nn) )
  ymn = minval ( y(1:nn) )
  ymx = maxval ( y(1:nn) )
  zmn = minval ( z(1:nn) )
  zmx = maxval ( z(1:nn) )

  xyzmin(1) = xmn
  xyzmin(2) = ymn
  xyzmin(3) = zmn
!
!  Compute cell dimensions and test for zero area.
!
  delx = (xmx-xmn) / real(nnr)
  dely = (ymx-ymn) / real(nnr)
  delz = (zmx-zmn) / real(nnr)

  xyzdel(1) = delx
  xyzdel(2) = dely
  xyzdel(3) = delz

  if ( delx == 0.0D+00 .or. dely == 0.0D+00 .or. delz == 0.0D+00 ) then
    ier = 2
    return
  end if
!
!  Initialize LCELL.
!
  lcell(1:nnr,1:nnr,1:nnr) = 0
!
!  Loop on nodes, storing indices in LCELL and LNEXT.
!
  np1 = nn + 1

  do ll = 1, nn
    lb = np1 - ll
    i = int((x(lb)-xmn)/delx) + 1
    if ( nnr < i ) i = nnr
    j = int((y(lb)-ymn)/dely) + 1
    if ( nnr < j ) j = nnr
    k = int((z(lb)-zmn)/delz) + 1
    if ( nnr < k ) k = nnr

    l = lcell(i,j,k)

    if ( l == 0 ) then
      lnext(lb) = lb
    else
      lnext(lb) = l
    end if

    lcell(i,j,k) = lb

  end do

  return
end
subroutine timestamp ( )

!*******************************************************************************
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    May 31 2001   9:45:54.872 AM
!
!  Modified:
!
!    31 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none
!
  character ( len = 8 ) ampm
  integer d
  character ( len = 8 ) date
  integer h
  integer m
  integer mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer n
  integer s
  character ( len = 10 )  time
  integer values(8)
  integer y
  character ( len = 5 ) zone
!
  call date_and_time ( date, time, zone, values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Fit the surface R to a parabola to obtain sub-pixel offsets (dx,dy)
c for the reseau mark coordinates.
c
c Reference: "Quadratic interpolation of the surface maximum",
c Gary Yagi, JPL IOM April 10, 2005

c The 3 horizontal pixels R(i-1,j),R(i,j),R(i+1,j) are fit to a parabola
c and then solving for the maximum of the parabola.  This determines dx.

c The 3 vertical pixels R(i,j-1),R(i,j),R(i,j+1) are treated the same way
c to obtain dy.

c Because of the 3x3 window, do not call this routine for (i,j) along
c the margins of the search area.

      subroutine interp_max(R,ir,jr,i,j,noin,rho,dx,dy)
      implicit none
c Inputs...
      integer ir,jr
      real*4 R(-ir:ir,-jr:jr)		!corr coef over search area
      integer i,j			!R(i,j) is the integer maximum
      logical noin
c Outputs...
      real*4 rho			!interpolated at (dx,dy)
      real*4 dx,dy			!sub-pixel offsets

c Local variables...
      real a,b,c
      real rx,ry

      c = R(i,j)
      rx = c
      ry = c
      dx = 0
      dy = 0
      if (noin) return

c Fit R(i-1,j), R(i,j), R(i+1,j) to a parabola to solve for dx
      if (R(i-1,j).gt.-1. .and. R(i+1,j).gt.-1.) then
         a = R(i+1,j) - 2*R(i,j) + R(i-1,j)
         b = R(i+1,j)-R(i-1,j)
         if (abs(a).gt.0.0001) then
            dx = -b/(2*a)
            rx = a*dx**2 + b*dx + c
         endif
      endif

c Fit R(i,j-1), R(i,j), R(i,j+1) to a parabola to solve for dy
      if (R(i,j-1).gt.-1. .and. R(i,j+1).gt.-1.) then
         a = R(i,j+1) - 2*R(i,j) + R(i,j-1)
         b = R(i,j+1) - R(i,j-1)
         if (abs(a).gt.0.0001) then
            dy = -b/(2*a)
            ry = a*dy**2 + b*dy + c
         endif
      endif
      rho = (rx + ry)/2
      if (rho.gt.1) rho=1
      return
      end


!  NAIVE - naive method for doing forward substitution.
!  Replace this module with one called SUBSTITUTION that implements
!  a vectorized version of both the forward and backward substitution
!  algorithms.  The vectorized versions should access memory more
!  efficiently than this version.

    module naive
    use precision
    implicit none
    contains
!------------------------------------------------------------------------------
    subroutine forward_naive(a, n, b, ierr)
!  FORWARD_NAIVE - naive implementation of forward substitution.
!  We seek to solve a linear system of the form Ax=b, where A is a
!  square lower-triangular matrix.
!
!  This routine is VERY INEFFICIENT for large matrices, because the innermost
!  loop traverses the rows of the matrix A instead of the columns.
!  Arguments:
!  A  : an NxN matrix, assumed lower triangular (the elements of the upper
!       triangle are not accessed).
!  N : the size of the problem
!  B :=: On input, the right-hand side to be solved for; on return, holds
!      the solution, X.
!  IERR := set to 0 unless an error occurs (i.e., the system is exactly
!     singular).

    integer, intent(in):: n
    real(DP), intent(in):: a(n,n)
    real(DP), intent(inout):: b(n)
    integer, intent(out):: ierr

!  Local variables

    integer:: j,k

!  Start with the first equation and forward substitute into the remainder

    ierr = 0
    do k = 1, n
       if(a(k,k).eq.0) goto 911  ! exactly singular problem
       do j = 1, k-1
          b(k) = b(k) - a(k,j)*b(j)
       enddo
       b(k) = b(k)/a(k,k)
    enddo  ! or END DO
    return

!  Oops

911 continue
    ierr = -1
    return
    end subroutine forward_naive
!------------------------------------------------------------------------------
    end module naive


      SUBROUTINE PAIR_FORCE(RSQ,FORCEIJ)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Calculates the force between a pair of atoms
!! Currently supports 6 different forcelaws
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      REAL(kind = double) :: FORCEIJ,RSQ
      REAL(kind = double) :: RRR,RR6,RR12
      REAL(kind = double) :: R,RDIF,RDIF2,RDIF3
      REAL(kind = double) :: RATIO
      REAL(kind = double) :: FACTOR

      SELECT CASE (IPOT_TYPE) ! choose option depending on potential type

        CASE(1)   ! Cut LJ potential

          RRR = 1.0D0/RSQ
          RR6 = RRR*RRR*RRR
          RR12 = RR6*RR6
          FORCEIJ = 48.0d0*EPS*(RR12 - 0.5d0*RR6)*RRR

        CASE(2)   ! Splined-LJ potential

          IF(RSQ.LE.RCUT_INNER_SQ) THEN
            RRR = 1.0D0/RSQ
            RR6 = RRR*RRR*RRR
            RR12 = RR6*RR6
            FORCEIJ = 48.0d0*EPS*(RR12 - 0.5d0*RR6)*RRR
          ELSE
            R = SQRT(RSQ)
            RDIF = R - RCUT
            RDIF2 = RDIF*RDIF
            RDIF3 = RDIF2*RDIF
            FORCEIJ = -(2.0d0*SPLINE_R2*RDIF + 3.0d0*SPLINE_R3*RDIF2)/R
          END IF

        CASE(3)   ! Smooth repulsive potential

          RATIO = RSQ/CUTSQ
          FORCEIJ = EPSIG8*(1.0D0 - RATIO)**3

        CASE(4)   ! m-n family of potentials

          FACTOR = 2.0D0 - RSQ
          FORCEIJ = FORCE_MN_FACT*(FACTOR**N_POWER_SUB1 - FACTOR**M_POWER_SUB1)

        CASE(5)   ! Lucy potential

          R = SQRT(RSQ)
          RATIO = R/RCUT
          FORCEIJ = FORCE_FACT_LUCY*(1.0D0 - RATIO)**2

        CASE(6)   ! Soft disk potential

          FORCEIJ = 2.0d0*SOFT_N/(RSQ**(SOFT_N+1))

        CASE(7)   ! WCA fluid
          RRR = 1.0D0/RSQ
          RR6 = RRR*RRR*RRR
          RR12 = RR6*RR6
          FORCEIJ = 48.0d0*(RR12 - 0.5d0*RR6)*RRR

      END SELECT

      END SUBROUTINE


!--------------------------------------------------
!PHY2063 Assignment 2
!URN 6309823 - Penguin Lab Group 1B
!January 11th 2016
!--------------------------------------------------

program A2
  implicit none

  integer,parameter ::  n=300
  real              ::  temp(-n:n),dtempdt(-n:n),temp_xx(-n:n)
  real,parameter    ::  h=0.1, diffc=1.1, dt=1E-4
  integer           ::  i,j,k
  real              ::  x

! temp(-n:n) = Temperature array
! dtempdt(-n:n) = differential of temperature with respect to time array
! temp_xx(-n:n) = laplacian opperator times
! h = grid spacing, diffc= diffusion constant, dt = time step
! [i,j,k] = iteration steps, x = region in the x axis

  open(unit=12,file='A2.dat')

  write(6,*)"This program uses an array of real numbers to calculate the time"
  write(6,*)"evolution, by diffusion, of a temperature distribution along the"
  write(6,*)"x-axis."

  temp=0.0

  do i=-10,10
    temp(i)=20.0
  enddo

  write(6,*)" "
  write(6,*)" "
  write(6,*)"The initial boundary conditions are:"
  write(6,*)"T=0 degrees C when x<-1 cm"
  write(6,*)"T=20 degrees C when -1<=x<=1 cm"
  write(6,*)"T=0 degrees C when x>1 cm"
  write(6,*)" "
  write(6,*)" "

  do i=0,100000

!   This integrates forward in time from t=0s to t=10s in increments of 10E-4.
    do j=-n+1,n-1

!     This calculates the values of dT/dt at each position.

!     dtempdt is the time derivative of the temperature.
!     diffc is the diffusion constant.

      temp_xx(j)=(temp(j+1)-2.0*temp(j)+temp(j-1))/h**2
      dtempdt(j)=diffc*temp_xx(j)

     end do
    do k=-n+1,n-1

!       This uses these values in the Euler method to calculate the temperature
!       at all x values.

        temp(k)=temp(k)+dt*dtempdt(k)

!       Find the error in result here.

      end do
  end do

  do i=-n,n

!   This do loop writes the values of distance x and temperature to the file
!   A0.dat

    x=real(i)*h
    write(12,*)x,Temp(i)
  end do
  close (12)

  write(6,*)"The distance, x, and the temperature, Temp(i), is found"
  write(6,*)" "
  write(6,*)"The data 'x,Temp(i)' is written to the file A2.dat"
  write(6,*)" "
  write(6,*)"Plot the data using gnuplot"
  write(6,*)"In gnuplot write: plot 'A2.dat' using 1:2 with lines"
end program A2


      PROGRAM xgauleg
C     driver for routine gauleg
      INTEGER NPOINT
      REAL X1,X2,X3
      PARAMETER(NPOINT=10,X1=0.0,X2=1.0,X3=10.0)
      INTEGER i
      REAL func,xx,x(NPOINT),w(NPOINT)
      call gauleg(X1,X2,x,w,NPOINT)
      write(*,'(/1x,t3,a,t10,a,t22,a/)') '#','X(I)','W(I)'
      do 11 i=1,NPOINT
        write(*,'(1x,i2,2f12.6)') i,x(i),w(i)
11    continue
C     demonstrate the use of GAULEG for an integral
      call gauleg(X1,X3,x,w,NPOINT)
      xx=0.0
      do 12 i=1,NPOINT
        xx=xx+w(i)*func(x(i))
12    continue
      write(*,'(/1x,a,f12.6)') 'Integral from GAULEG:',xx
      write(*,'(1x,a,f12.6)') 'Actual value:',1.0-(1.0+X3)*exp(-X3)
      END
      REAL FUNCTION func(x)
      REAL x
      func=x*exp(-x)
      END

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


program test_arpack
use arpack, only: eig
use types, only: dp
use utils, only: stop_error
implicit none

integer :: n, nev, ncv, i
real(dp), allocatable :: d(:), v(:,:)
real(dp), parameter :: e_ref(4) =  [4.8308300260037749_dp, &
    5.3097214678905722_dp, 5.6825070656623593_dp, 5.9189859472289967_dp]

n = 10
nev = 4
ncv = 10
allocate(v(n,ncv), d(ncv))
call eig(n, nev, ncv, "LM", av, d, v)
do i = 1, nev
    print *, d(i), abs(d(i) - e_ref(i))
    if (abs(d(i) - e_ref(i)) > 1e-14_dp) call stop_error("Error in ref. check")
end do

contains

  subroutine av(x, y)
  ! Compute y = A*x
  real(dp), intent(in) :: x(:)
  real(dp), intent(out) :: y(:)
  real(dp) :: dd, dl, du
  integer :: j
  dd = 4
  dl = -1
  du = -1
  y(1) = dd*x(1) + du*x(2)
  do j = 2, size(y)-1
     y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1)
  end do
  y(size(y)) = dl*x(size(y)-1) + dd*x(size(y))
  end

end