! ------------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
! ------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2022, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ------------------------------------------------------------------
! Example problem:
!
! The following is a simple example problem with analytical
! solution,
!    dy/dt = lamda*y + 1/(1+t^2) - lamda*atan(t)
!
! The stiffness of the problem is directly proportional to the
! value of "lamda", which is specified through an input file.  The
! real part of lamda should be negative to result in a well-posed
! ODE; for lambdas with magnitude larger than 100 the problem
! becomes quite stiff.
!
! Here we choose lamda = -0.1 + 10 i.
!
! This program solves the problem with the ERK method and
! a user-supplied complex vector module.
! Output is printed every 1.0 units of time (10 total).
! Run statistics (optional outputs) are printed at the end.
! ------------------------------------------------------------------

module ode_mod

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  !======= Declarations =========
  implicit none
  integer(c_long),            parameter :: neq = 1
  integer(c_int),             parameter :: Nt = 10
  complex(c_double_complex),  parameter :: lambda = (-1d-2, 10.d0)
  real(c_double),             parameter :: T0 = 0.d0
  real(c_double),             parameter :: Tf = 10.d0
  real(c_double),             parameter :: dtmax = 0.01d0
  real(c_double),             parameter :: reltol = 1.d-6
  real(c_double),             parameter :: abstol = 1.d-10

contains

  ! ----------------------------------------------------------------
  ! Rhs provides the right hand side function for the ODE:
  ! dy/dt = f(t,y).
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function Rhs(tn, sunvec_y, sunvec_f, user_data) &
       result(ierr) bind(C,name='Rhs')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fnvector_complex_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn  ! current time
    type(N_Vector) :: sunvec_y   ! solution N_Vector
    type(N_Vector) :: sunvec_f   ! rhs N_Vector
    type(c_ptr)    :: user_data  ! user-defined data

    ! local variables
    type(FVec), pointer :: y, f  ! ptrs to Fortran vector data

    !======= Internals ============

    ! extract Fortran vector structures to work with
    y => FN_VGetFVec(sunvec_y)
    f => FN_VGetFVec(sunvec_f)

    ! evaluate ODE RHS and return success
    f%data(1) = lambda*y%data(1)
    ierr = 0

  end function Rhs

  ! ----------------------------------------------------------------
  ! Sol provides the analytical solution to the ODE.
  ! ----------------------------------------------------------------
  complex(c_double_complex) function Sol(tn) result(y)

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fnvector_complex_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn  ! current time

    !======= Internals ============

    ! fill analytical solution for this value of tn, and return
    y = 2.d0*exp(lambda*tn)
    return

  end function Sol

end module ode_mod

program main

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  use farkode_mod           ! Fortran interface to the ARKode module
  use farkode_arkstep_mod   ! Fortran interface to the ARKStep module
  use fnvector_complex_mod  ! Custom complex N_Vector
  use fsundials_context_mod
  use ode_mod               ! ODE functions

  !======= Declarations =========
  implicit none

  ! local variables
  integer(c_int)          :: ierr, iout
  real(c_double)          :: tcur(1), tout, dTout, yerr, yerrI, yerr2
  type(N_Vector), pointer :: sunvec_y    ! SUNDIALS vector
  type(c_ptr)             :: arkode_mem  ! ARKODE memory
  type(c_ptr)             :: sunctx      ! SUNDIALS context for the simulation

  ! solution vector
  type(FVec), pointer :: y

  !======= Internals ============

  ! create the SUNDIALS context
  ierr = FSUNContext_Create(c_null_ptr, sunctx)

  ! initial problem output
  print *, "  "
  print *, "Analytical ODE test problem:"
  print '(2(a,f5.2),a)', "    lambda = (", real(lambda), " , ", imag(lambda), " ) "
  print '(2(a,es8.1))', "    reltol = ",reltol,",  abstol = ",abstol

  ! initialize SUNDIALS solution vector
  sunvec_y => FN_VNew_Complex(neq, sunctx)
  if (.not. associated(sunvec_y)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if
  y => FN_VGetFVec(sunvec_y)

  ! Set initial conditions into y
  y%data(1) = Sol(T0)

  ! create ARKStep memory
  arkode_mem = FARKStepCreate(c_funloc(Rhs), c_null_funptr, T0, sunvec_y, sunctx)
  if (.not. c_associated(arkode_mem)) then
     print *,'ERROR: arkode_mem = NULL'
     stop 1
  end if

  ! main time-stepping loop: calls FARKStepEvolve to perform the integration, then
  ! prints results.  Stops when the final time has been reached
  tcur(1) = T0
  dTout = (Tf-T0)/Nt
  tout = T0+dTout
  yerrI = 0.d0
  yerr2 = 0.d0
  print *, " "
  print *, "      t     real(u)    imag(u)    error"
  print *, "   -------------------------------------------"
  print '(5x,f4.1,2(2x,es9.2),2x,es8.1)', tcur(1), real(y%data(1)), imag(y%data(1)), 0.d0
  do iout = 1,Nt

     ! call integrator
     ierr = FARKStepEvolve(arkode_mem, tout, sunvec_y, tcur, ARK_NORMAL)
     if (ierr /= 0) then
        write(*,*) 'Error in FARKStepEvolve, ierr = ', ierr, '; halting'
        stop 1
     endif

     ! compute/accumulate solution error
     yerr  = abs( y%data(1) - Sol(tcur(1)) )
     yerrI = max(yerrI, yerr)
     yerr2 = yerr2 + yerr**2

     ! print solution statistics
     print '(5x,f4.1,2(2x,es9.2),2x,es8.1)', tcur(1), real(y%data(1)), imag(y%data(1)), yerr

     ! update output time
     tout = min(tout + dTout, Tf)

  end do
  yerr2 = dsqrt( yerr2 / Nt )
  print *, "   -------------------------------------------"

  ! diagnostics output
  call ARKStepStats(arkode_mem)
  print '(2(a,es9.2))', "    Error: max = ", yerrI, ", rms = ", yerr2
  print *, ' '

  ! clean up
  call FARKStepFree(arkode_mem)
  call FN_VDestroy(sunvec_y)
  ierr = FSUNContext_Free(sunctx)

end program main

! ----------------------------------------------------------------
! ARKStepStats
!
! Print ARKODE statstics to standard out
! ----------------------------------------------------------------
subroutine ARKStepStats(arkode_mem)

  !======= Inclusions ===========
  use iso_c_binding
  use farkode_mod
  use farkode_arkstep_mod

  !======= Declarations =========
  implicit none

  type(c_ptr), intent(in) :: arkode_mem ! solver memory structure

  integer(c_int)  :: ierr         ! error flag
  integer(c_long) :: nsteps(1)    ! num steps
  integer(c_long) :: nst_a(1)     ! num steps attempted
  integer(c_long) :: nfe(1)       ! num explicit function evals
  integer(c_long) :: nfi(1)       ! num implicit function evals
  integer(c_long) :: netfails(1)  ! num error test fails

  !======= Internals ============

  ierr = FARKStepGetNumSteps(arkode_mem, nsteps)
  ierr = FARKStepGetNumStepAttempts(arkode_mem, nst_a)
  ierr = FARKStepGetNumRhsEvals(arkode_mem, nfe, nfi)
  ierr = FARKStepGetNumErrTestFails(arkode_mem, netfails)

  print *, ' '
  print *, 'Final Solver Statistics:'
  print '(4x,2(A,i4),A)' ,'Internal solver steps = ',nsteps(1),', (attempted = ',nst_a(1),')'
  print '(4x,A,i5)'   ,'Total RHS evals = ',nfe(1)
  print '(4x,A,i5)'      ,'Total number of error test failures =',netfails(1)

  return

end subroutine ARKStepStats


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

! Smallest multiple
!
! 2520 is the smallest number that can be divided by each of the numbers
! from 1 to 10 without any remainder.
!
! What is the smallest positive number that is evenly divisible by all of
! the numbers from 1 to 20?
module MPEProblem5

    implicit none
    private

    type, public :: TPEProblem5
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 5. Smallest multiple.'

        write (*, '(A, I)') 'Multiple 1: ', multiple1()
        write (*, '(A, I)') 'Multiple 2: ', multiple2()
    end subroutine

    function multiple1()
        integer multiple1
        integer base
        logical flag

        do multiple1 = 1, huge(multiple1)
            flag = .true.

            do base = 1, 20
                if (mod(multiple1, base) .ne. 0) then
                    flag = .false.
                end if
            end do

            if (flag .eq. .true.) then
                return
            end if
        end do
    end function

    function multiple2()
        integer multiple2
        integer base
        logical flag

        do multiple2 = 1, huge(multiple2)
            flag = .true.

            do base = 2, 20
                if (mod(multiple2, base) .ne. 0) then
                    flag = .false.
                    exit
                end if
            end do

            if (flag .eq. .true.) then
                return
            end if
        end do
    end function
end module


module prod

implicit none

contains

Subroutine ProdNoIntent(x,y,z)
real x,y,z
! This subroutine will not pass result back to Python,
! since f2py assumes INTENT(IN) instead of INTENT(INOUT) like
! plain FORTRAN compilers
z = x * y

End Subroutine

Subroutine ProdIntent(x,y,z)
! This subroutine will pass result back to Python
! Note that intent(in) is not invincible, subroutines called by
! subroutines can modify the original variable IF the 2nd subroutine
! doesn't have Intent(in)
real,Intent(In) :: x,y
real,Intent(Out):: z

z = x * y

End Subroutine

Subroutine ProdInOut(x,y,z)
! This subroutine will pass result back to Python IN PLACE, not on the left-hand
! of the equals sign! Requires ndarray on inout variable even for scalar cases!
real, Intent(In) :: x,y
real, Intent(inout)  :: z
z = x * y
End Subroutine

Pure Real Function prodpure(x,y)
! Elemental & Pure functions require intent declaration
real, Intent(in) :: x,y

prodpure = x*y

End Function

end module prod


module ad_usr_func

    use ad_kinds, only: rk
    use ad_types, only: tree_t, assignment(=)
    implicit none
    private

    public :: sigmoid

contains

    impure elemental function sigmoid(t1) result(t)
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = 1.0_rk/(1.0_rk + exp(-t1%node%value))

        t%node%left => t1%node
        t%node%left_grad = t%node%value*(1.0_rk - t%node%value)

    end function sigmoid

end module ad_usr_func


program t
  integer :: i = 10
  integer, dimension(10) :: a, b

  do i = 1,10,1
    a(i) = i
    b(i) = -i
  end do
  where ( a  < 7 .and. a > 3)
    a = 22
    b = -22
  elsewhere (a >= 7)
    a =  33
    b = -33
  elsewhere
    a = 44
    b = -44
  end where

  print *, a
  print *, b

end program t


subroutine parse_commandline(csvfile, kernelfile, power1, power2)
! =============================================================================
! Parses the command lines inputs
! csvfile    : the .csv file from which the kernel will be constructed
! kernelfile : the name of the .kernel file to be written
! power1     : the value of M (from 0 to 6 inclusive) for dimension 1
! power2     : the value of M (from 0 to 6 inclusive) for dimension 2
! =============================================================================
    implicit none
    character(len=256), intent(out) :: csvfile, kernelfile
    character(len=256)              :: strpower1, strpower2
    integer, intent(out)            :: power1, power2

    if (command_argument_count().ne.4) then
        write(*,*) "ERROR: requires 'csvfile', 'kernelfile', 'power1', 'power2'"
        stop
    endif

    ! read arguments from the command line
    call get_command_argument(1, csvfile)
    call get_command_argument(2, kernelfile)
    call get_command_argument(3, strpower1)
    call get_command_argument(4, strpower2)

    ! convert strpower to power
    read(strpower1, *) power1
    read(strpower2, *) power2

    if ( (power1.lt.0) .or. (power1.gt.6) ) then
        write(*,*) "ERROR: power1 must be between 0 and 6, inclusive"
        stop
    endif

    if ( (power2.lt.0) .or. (power2.gt.6) ) then
        write(*,*) "ERROR: power2 must be between 0 and 6, inclusive"
        stop
    endif
end subroutine

program example
use RKHS            ! This module needs to be used by your code
implicit none

type(kernel)       :: K                   ! The kernel type
character(len=256) :: csvfile, kernelfile ! names of files
integer            :: power1, power2      ! powers for the 1D kernels

call parse_commandline(csvfile, kernelfile, power1, power2) ! read command line inputs
call K%read_grid(trim(csvfile))                             ! read training data

!   choose one-dimensional kernel for dimension 1
if      (power1 == 0) then
    call K%k1d(1)%init(RECIPROCAL_POWER_N2_M0_KERNEL)
else if (power1 == 1) then
    call K%k1d(1)%init(RECIPROCAL_POWER_N2_M1_KERNEL)
else if (power1 == 2) then
    call K%k1d(1)%init(RECIPROCAL_POWER_N2_M2_KERNEL)
else if (power1 == 3) then
    call K%k1d(1)%init(RECIPROCAL_POWER_N2_M3_KERNEL)
else if (power1 == 4) then
    call K%k1d(1)%init(RECIPROCAL_POWER_N2_M4_KERNEL)
else if (power1 == 5) then
    call K%k1d(1)%init(RECIPROCAL_POWER_N2_M5_KERNEL)
else if (power1 == 6) then
    call K%k1d(1)%init(RECIPROCAL_POWER_N2_M6_KERNEL)
else
    write(*,*) "ERROR: something went wrong initializing the kernel for dimension 1"
    stop
endif

!   choose one-dimensional kernel for dimension 2
if      (power2 == 0) then
    call K%k1d(2)%init(RECIPROCAL_POWER_N2_M0_KERNEL)
else if (power2 == 1) then
    call K%k1d(2)%init(RECIPROCAL_POWER_N2_M1_KERNEL)
else if (power2 == 2) then
    call K%k1d(2)%init(RECIPROCAL_POWER_N2_M2_KERNEL)
else if (power2 == 3) then
    call K%k1d(2)%init(RECIPROCAL_POWER_N2_M3_KERNEL)
else if (power2 == 4) then
    call K%k1d(2)%init(RECIPROCAL_POWER_N2_M4_KERNEL)
else if (power2 == 5) then
    call K%k1d(2)%init(RECIPROCAL_POWER_N2_M5_KERNEL)
else if (power2 == 6) then
    call K%k1d(2)%init(RECIPROCAL_POWER_N2_M6_KERNEL)
else
    write(*,*) "ERROR: something went wrong initializing the kernel for dimension 2"
    stop
endif

! choose one-dimensional kernel for dimension 3
call K%k1d(3)%init(TAYLOR_SPLINE_N2_KERNEL)

call K%calculate_coefficients_fast()   ! calculate the coefficients (uses Tensor product)
call K%calculate_sums()                ! this call will calculate the complete lookup table
call K%save_to_file(trim(kernelfile))  ! save the kernel to a binary file
call K%free()                          ! free the kernel memory

end program example


        subroutine idzr_id(m,n,a,krank,list,rnorms)
c
c       computes the ID of a, i.e., lists in list the indices
c       of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                        krank
c       a(j,list(k))  =  Sigma  a(j,list(l)) * proj(l,k-krank)       (*)
c                         l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon, dimensioned epsilon(m,n-krank),
c       whose norm is (hopefully) minimized by the pivoting procedure.
c       The present routine stores the krank x (n-krank) matrix proj
c       in the memory initially occupied by a.
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a, as well as the dimension required
c            of list
c       a -- matrix to be ID'd
c       krank -- desired rank of the output matrix
c                (please note that if krank > m or krank > n,
c                then the rank of the output matrix will be
c                less than krank)
c
c       output:
c       a -- the first krank*(n-krank) elements of a constitute
c            the krank x (n-krank) interpolation matrix proj
c       list -- list of the indices of the krank columns of a
c               through which the other columns of a are expressed;
c               also, list describes the permutation of proj
c               required to reconstruct a as indicated in (*) above
c       rnorms -- absolute values of the entries on the diagonal
c                 of the triangular matrix used to compute the ID
c                 (these may be used to check the stability of the ID)
c
c       _N.B._: This routine changes a.
c
c       reference:
c       Cheng, Gimbutas, Martinsson, Rokhlin, "On the compression of
c            low-rank matrices," SIAM Journal on Scientific Computing,
c            26 (4): 1389-1404, 2005.
c
        implicit none
        integer m,n,krank,j,k,list(n),iswap
        real*8 rnorms(n),ss
        complex*16 a(m,n)
c
c
c       QR decompose a.
c
        call idzr_qrpiv(m,n,a,krank,list,rnorms)
c
c
c       Build the list of columns chosen in a
c       by multiplying together the permutations in list,
c       with the permutation swapping 1 and list(1) taken rightmost
c       in the product, that swapping 2 and list(2) taken next
c       rightmost, ..., that swapping krank and list(krank) taken
c       leftmost.
c
        do k = 1,n
          rnorms(k) = k
        enddo ! k
c
        if(krank .gt. 0) then
          do k = 1,krank
c
c           Swap rnorms(k) and rnorms(list(k)).
c
            iswap = rnorms(k)
            rnorms(k) = rnorms(list(k))
            rnorms(list(k)) = iswap
c
          enddo ! k
        endif
c
        do k = 1,n
          list(k) = rnorms(k)
        enddo ! k
c
c
c       Fill rnorms for the output.
c
        ss = 0
c
        do k = 1,krank
          rnorms(k) = a(k,k)
          ss = ss + rnorms(k)**2
        enddo ! k
c
c
c       Backsolve for proj, storing it at the beginning of a.
c
        if(krank .gt. 0 .and. ss .gt. 0) then
          call idz_lssolve(m,n,a,krank)
        endif
c
        if(ss .eq. 0) then
c
          do k = 1,n
            do j = 1,m
c
              a(j,k) = 0
c
            enddo ! j
          enddo ! k
c
        endif
c
c
        return
        end
c
c
c
c


program sudoku

  implicit none
  integer, dimension (9, 9) :: grid
  integer, dimension (9, 9) :: grid_solved
  grid = reshape ((/               &
    & 0, 0, 3, 0, 2, 0, 6, 0, 0,   &
    & 9, 0, 0, 3, 0, 5, 0, 0, 1,   &
    & 0, 0, 1, 8, 0, 6, 4, 0, 0,   &
    & 0, 0, 8, 1, 0, 2, 9, 0, 0,   &
    & 7, 0, 0, 0, 0, 0, 0, 0, 8,   &
    & 0, 0, 6, 7, 0, 8, 2, 0, 0,   &
    & 0, 0, 2, 6, 0, 9, 5, 0, 0,   &
    & 8, 0, 0, 2, 0, 3, 0, 0, 9,   &
    & 0, 0, 5, 0, 1, 0, 3, 0, 0/), &
    & shape = (/9, 9/),            &
    & order = (/2, 1/))
  call pretty_print (grid)
  call solve (1, 1)
  write (*, *)
  call pretty_print (grid_solved)

contains

  recursive subroutine solve (i, j)
    implicit none
    integer, intent (in) :: i
    integer, intent (in) :: j
    integer :: n
    integer :: n_tmp
    if (i > 9) then
      grid_solved = grid
    else
      do n = 1, 9
        if (is_safe (i, j, n)) then
          n_tmp = grid (i, j)
          grid (i, j) = n
          if (j == 9) then
            call solve (i + 1, 1)
          else
            call solve (i, j + 1)
          end if
          grid (i, j) = n_tmp
        end if
      end do
    end if
  end subroutine solve

  function is_safe (i, j, n) result (res)
    implicit none
    integer, intent (in) :: i
    integer, intent (in) :: j
    integer, intent (in) :: n
    logical :: res
    integer :: i_min
    integer :: j_min
    if (grid (i, j) == n) then
      res = .true.
      return
    end if
    if (grid (i, j) /= 0) then
      res = .false.
      return
    end if
    if (any (grid (i, :) == n)) then
      res = .false.
      return
    end if
    if (any (grid (:, j) == n)) then
      res = .false.
      return
    end if
    i_min = 1 + 3 * ((i - 1) / 3)
    j_min = 1 + 3 * ((j - 1) / 3)
    if (any (grid (i_min : i_min + 2, j_min : j_min + 2) == n)) then
      res = .false.
      return
    end if
    res = .true.
  end function is_safe

  subroutine pretty_print (grid)
    implicit none
    integer, dimension (9, 9), intent (in) :: grid
    integer :: i
    integer :: j
    character (*), parameter :: bar = '+-----+-----+-----+'
    character (*), parameter :: fmt = '(3 ("|", i0, 1x, i0, 1x, i0), "|")'
    write (*, '(a)') bar
    do j = 0, 6, 3
      do i = j + 1, j + 3
        write (*, fmt) grid (i, :)
      end do
      write (*, '(a)') bar
    end do
  end subroutine pretty_print

end program sudoku


c     Program DRSPOLZ2
c>> 2009-10-28 DRZPOLZ2 Krogh Mods to get comples used in single prec.
c>> 1996-07-03 DRSPOLZ2 Krogh Set for deriving single precision C vers.
c>> 1995-05-28 DRSPOLZ2 Krogh Moved formats up.
c>> 1994-08-09 DRSPOLZ2 WVS Removed '0' in format
c>> 1991-11-20 DRSPOLZ2 CLL Editing for Fortran 90.
c>> 1987-12-09 DRSPOLZ2 Lawson  Initial Code.
c Conversion should only be done from "D" to "S" for processing to C.
c--S replaces "?": DR?POLZ2, ?POLZ2
c     Demonstration driver for SPOLZ2.
c
      real              DC(3,3)
c++ CODE for .D. | .C. is inactive
C      real             Z(2,2)
c++ CODE for .S. & ~.C. is active
      complex Z(2)
c++ END

      integer  I, J, K, N
c
      data (DC(I,1),I=1,3) / 1.E0, 1.E0, -1.E0 /
      data (DC(I,2),I=1,3) / 2.E0, -12.E0, 26.E0 /
      data (DC(I,3),I=1,3) / 1.E0, -4.E0, 4.E0 /
      data N / 2 /
c
  100 format(' ','Degree =',I2/' ',
     *       'Coefficients =',6X,3(F10.4,1X))
  200 format(' ','Roots ='/(2(1X:'(',1X,F8.5,',',1X,F8.5,2X,')',2X)))
  300 format(//' ')
c
      do 40 J = 1,3
         print 100, N, (DC(I, J),I=1,3)
        call SPOLZ2(DC(1,J),Z)
c++ CODE for .D. & ~.C. is inactive
C        print '('' Roots =''/(2(1X:''('',1X,F8.5,'','',1X,F8.5,2X,
C     *    '')'',2X)))', (Z(1,K),Z(2,K),K=1,2)
c++ CODE for .S. & ~.C. is active
        print '('' Roots =''/(2(1X:''('',1X,F8.5,'','',1X,F8.5,2X,
     *    '')'',2X)))', (Z(K),K=1,2)
c++ CODE for .C. is inactive
c%%        printf( "\n Roots =\n  ( %8.5f, %8.5f )  ( %8.5f, %8.5f ) ",
c%%           z[0][0], z[0][1], z[1][0], z[1][1] );
c++ End
        print 300
   40 continue
      end


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE SUMMRY (TYPE, NUM, SELECT, VALUE, SUMR, ISUMR, IOFF)
      CHARACTER*(*) TYPE
      LOGICAL SELECT(*)
      REAL VALUE(*), SUMR(*)
      INTEGER ISUMR(*)

C ... TYPE = 'A' - calculate stats based on absolute values
C              NOTE: VALUE will be modified if this option used
C          = ' ' - calculate stats based on true value

C ... SUMR(1) = MINIMUM   ISUMR(1) = ELEMENT NUMBER
C ... SUMR(2) = MAXIMUM   ISUMR(2) = ELEMENT NUMBER
C ... SUMR(3) = AVERAGE
C ... SUMR(4) = STD. DEV.

      SUMR(1) =  1.0E30
      SUMR(2) = -1.0E30
      NUMSEL = 0

      RMEAN  = 0.0
      STDDEV = 0.0

      IF (TYPE(:1) .EQ. 'A') THEN
         DO 5 I=1, NUM
            VALUE(I) = ABS(VALUE(I))
    5    CONTINUE
      END IF

      DO 10 I = 1, NUM
         IF (SELECT(I)) THEN
            NUMSEL = NUMSEL + 1
            TMEAN  = RMEAN + (VALUE(I) - RMEAN) / NUMSEL
            STDDEV = STDDEV + (VALUE(I) - RMEAN) * (VALUE(I) - TMEAN)
            RMEAN  = TMEAN

            IF (VALUE(I) .LT. SUMR(1)) THEN
               SUMR(1) = VALUE(I)
               ISUMR(1) = I
            END IF

            IF (VALUE(I) .GT. SUMR(2)) THEN
               SUMR(2) = VALUE(I)
               ISUMR(2) = I
            END IF

         END IF
   10 CONTINUE

      SUMR(3) = RMEAN
      SUMR(4) = SQRT(STDDEV / MAX(1.0, DBLE(NUMSEL-1)))

      ISUMR(1) = ISUMR(1) + IOFF
      ISUMR(2) = ISUMR(2) + IOFF

      RETURN
      END


      subroutine ZSUM(Z1, Z2, RESULT)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1995-10-30 ZSUM  Krogh   Fixed so M77CON can get S.P. for C conv.
C>> 1987-12-07 ZSUM  Lawson  Initial code.
c--Z replaces "?": ?SUM
C
C     Computes the sum of two double precision complex numbers.
C     Computes W = U + V where the data is given as
C        Z1(1)   = Real part of U
C        Z1(2)   = Imaginary part of U
C        Z2(1) = Real part of V
C        Z2(2) = Imaginary part of V
C     Result returned as
C        RESULT(1)  = Real part of W
C        RESULT(2)  = Imaginary part of W
C
C     C.L.Lawson & S.Chan, JPL, Feb 17, 1987.
C     ------------------------------------------------------------------
C
      double precision Z1(2),Z2(2),RESULT(2), TEMP
c
      TEMP = Z1(1) + Z2(1)
      RESULT(2) = Z1(2) + Z2(2)
      RESULT(1) = TEMP
      return
      end


MODULE sub
    USE param
REAL dt,dx,dy,g
REAL hzero(0:ny+1,0:nx+1), h(0:ny+1,0:nx+1)
REAL eta(0:ny+1,0:nx+1),etan(0:ny+1,0:nx+1)
REAL*4 u(0:ny+1,0:nx+1), un(0:ny+1,0:nx+1)
REAL v(0:ny+1,0:nx+1), vn(0:ny+1,0:nx+1)
REAL eps ! parameter for Shapiro filter
CONTAINS

!=======================
SUBROUTINE init
!USE param

INTEGER j,k

INTEGER wet(0:ny+1,0:nx+1)
REAL hmin

hmin = 0.05

! grid parameters
dx = 10.0
dy = 10.0
dt = 0.1

! physical parameters
g = 9.81

! initial conditions

DO j = 0,ny+1
DO k = 0,nx+1
  hzero(j,k) = 10.0
END DO
END DO

! land boundaries with 10 m elevation
DO k = 0,nx+1
 hzero(0,k) = -10.0
! hzero(1,k) = -0.0
 hzero(ny+1,k) = -10.0
! hzero(ny,k) = -0.0
END DO

!DO j = 39,41
!DO k = 39,41
!hzero(j,k) = 0.0
!END DO
!END DO

DO j = 0,ny+1
 hzero(j,0) = -10.0
 hzero(j,nx+1) = -10.0
END DO

DO j = 0,ny+1
DO k = 0,nx+1
  eta(j,k) = -MIN(0.0,hzero(j,k))
  etan(j,k) = eta(j,k)
END DO
END DO
!XXXXXXXXXXXXXXXXXXX

DO j = 0,ny+1
DO k = 0,nx+1
  h(j,k) = hzero(j,k)+eta(j,k)
! wet = 1 defines "wet" grid cells
! wet = 0 defines "dry" grid cells
  wet(j,k) = 1
  if(h(j,k) < hmin)wet(j,k) = 0
  u(j,k) = 0.
  un(j,k) = 0.
  v(j,k) = 0.
  vn(j,k) = 0.
END DO
END DO

END SUBROUTINE init

!================
SUBROUTINE dyn
!USE param

INTEGER j,k

INTEGER wet(0:ny+1,0:nx+1)

! local parameters
REAL du(0:ny+1,0:nx+1), dv(0:ny+1,0:nx+1)
REAL uu, vv, duu, dvv
REAL hue, huw, hwp, hwn, hen, hep
REAL hvn, hvs, hsp, hsn, hnn, hnp

DO j = 1,ny
DO k = 1,nx
  du(j,k) = -dt*g*(eta(j,k+1)-eta(j,k))/dx
  dv(j,k) = -dt*g*(eta(j+1,k)-eta(j,k))/dy
END DO
END DO

DO j = 1,ny
DO k = 1,nx

! prediction for u
un(j,k) = 0.0
uu = u(j,k)
duu = du(j,k)
IF(wet(j,k)==1) THEN
  IF((wet(j,k+1)==1).or.(duu>0.0)) un(j,k) = uu+duu
ELSE
  IF((wet(j,k+1)==1).and.(duu<0.0)) un(j,k) = uu+duu
END IF

! prediction for v
vv = v(j,k)
dvv = dv(j,k)
vn(j,k) = 0.0
IF(wet(j,k)==1) THEN
  IF((wet(j+1,k)==1).or.(dvv>0.0)) vn(j,k) = vv+dvv
ELSE
  IF((wet(j+1,k)==1).and.(dvv<0.0)) vn(j,k) = vv+dvv
END IF

END DO
END DO

! sea level predictor
DO j = 1,ny
DO k = 1,nx
  hep = 0.5*(un(j,k)+abs(un(j,k)))*h(j,k)
  hen = 0.5*(un(j,k)-abs(un(j,k)))*h(j,k+1)
  hue = hep+hen
  hwp = 0.5*(un(j,k-1)+abs(un(j,k-1)))*h(j,k-1)
  hwn = 0.5*(un(j,k-1)-abs(un(j,k-1)))*h(j,k)
  huw = hwp+hwn

  hnp = 0.5*(vn(j,k)+abs(vn(j,k)))*h(j,k)
  hnn = 0.5*(vn(j,k)-abs(vn(j,k)))*h(j+1,k)
  hvn = hnp+hnn
  hsp = 0.5*(vn(j-1,k)+abs(vn(j-1,k)))*h(j-1,k)
  hsn = 0.5*(vn(j-1,k)-abs(vn(j-1,k)))*h(j,k)
  hvs = hsp+hsn
  etan(j,k) = eta(j,k)-dt*(hue-huw)/dx-dt*(hvn-hvs)/dy
END DO
END DO

END SUBROUTINE dyn

!======================
SUBROUTINE shapiro
!USE param

INTEGER j,k

INTEGER wet(0:ny+1,0:nx+1)

!local parameters
REAL term1,term2,term3

! 1-order Shapiro filter

DO j = 1,ny
DO k = 1,nx

IF(wet(j,k)==1)THEN
  term1 = (1.0-0.25*eps*(wet(j,k+1)+wet(j,k-1)+ wet(j+1,k)+wet(j-1,k)))*etan(j,k)
  term2 = 0.25*eps*(wet(j,k+1)*etan(j,k+1)+wet(j,k-1)*etan(j,k-1))
  term3 = 0.25*eps*(wet(j+1,k)*etan(j+1,k)+wet(j-1,k)*etan(j-1,k))
  eta(j,k) = term1+term2+term3
ELSE
  eta(j,k) = etan(j,k)
END IF

END DO
END DO

END SUBROUTINE shapiro

END MODULE sub


      MODULE MOD_CSTABREAD

      contains

      SUBROUTINE cstabread(SIGMA, WAVENUM, LOW, WAVARR, SIGARR, N, NF)

C     CALLED BY PHOTOCS_M
C     written by Margit Haberreiter to read cross section tables

      USE MOD_INTPL
      USE UTILS

      IMPLICIT NONE

      INTEGER, intent(in) :: LOW, N, NF

      real*8, intent(in) :: WAVENUM, SIGARR(N, NF), WAVARR(N, NF)

      real*8, intent(out) :: SIGMA

      integer :: nup, nlow, k, ii

      real*8 :: WAV1, SIG1, WAV2, SIG2

!      do ii = 1, N

!         do k = 1, NF

!            write(*, '(A,2x,4(i4,2x),2(2x,e15.7))'), 'cstabread:', ii, N, k, NF, wavarr(ii, k), wavenum

!         enddo

!      enddo

!      stop

      SIGMA = 0.

      ! find the index k in the reverse-sorted array WAVARR(low,:)
      ! such that WAVARR(low,k)>= wavenum >= WAVARR(low,k+1)
      ! using a binary search tree. Runtime is O(ln2(NF))
      nlow = 1

      nup = NF

      BIN_SEARCH: DO ii = 1, 999 ! safety guard if list is unorderd

        k = (nup + nlow) / 2

!        write(*, '(A,2x,4(i4,2x),2(e15.7,2x))'), 'cstabread:', low, N, k, NF, wavenum, wavarr(low, k)
!        if (low .le. 0 .or. low .gt. N .or. k .le. 0 .or. k .gt. NF) write(*, '(A,2(2x,i4))'), 'cstabread:', low, k

        IF (wavenum .gt. WAVARR(low, k)) THEN

           nup = k

        ELSE

           nlow = k

        ENDIF

        IF (nlow + 1 .ge. nup) exit

      ENDDO BIN_SEARCH

      k = nlow

      !* check for correct result and warn(1) if an overflow occured
      call assert(ii .lt. 900,'cstabread: BIN_SEARCH: WAVARR unsorted?',1)
      call assert((WAVARR(low, k) .ge. wavenum) .and. (WAVARR(low, k + 1) .le. wavenum),
     &            'cstabread: wavenum does not fit, Index not correct')
      !* End Binary search

      WAV1 = WAVARR(low, k)
      SIG1 = SIGARR(low, K)
      WAV2 = WAVARR(low, k + 1)
      SIG2 = SIGARR(low, k + 1)

      call intpl(SIGMA,WAVENUM,WAV1,WAV2,SIG1,SIG2)

      SIGMA = SIGMA * 1.d-18

      END SUBROUTINE

      END MODULE


C     PROGRAM No. 2: DISCRETE VORTEX METHOD (THIN WING, ELLIPTIC CAMBER)
C     -----------------------------------------------------------------
C     DISCRETE VORTEX MODEL FOR THIN AIRFOILS (JOE KATZ, CIRCA 1986)

      DIMENSION GAMMA(52),XC(52),ZC(52),X(52),Z(52)
      DIMENSION ENX(52),ENZ(52),A(52,52),IP(52)
      DIMENSION DL(52),DCP(52),DCP1(52)

      N=10
      C=1.0
      EPSILON=0.1*C
      ALFA1=10.0
      PAY=3.141592654
      ALFA=ALFA1*PAY/180.0
      RO=1.
      V=1.
      UINF=COS(ALFA)*V
      WINF=SIN(ALFA)*V
      QUE=0.5*RO*V*V

C     GRID GENERATION (N PANELS)

      DX=C/N
      DO 1 I=1,N
C     COLLOCATION POINT
      XC(I) = C/N*(I-0.25)
      ZC(I) = 4.*EPSILON*XC(I)/C*(1.-XC(I)/C)
C     VORTEX POINT
      X(I) = C/N*(I-0.75)
      Z(I) = 4.*EPSILON*X(I)/C*(1.-X(I)/C)
C     NORMAL AT COLLOCATION POINT; N=(ENX,ENZ)
      DETADX=4.*EPSILON/C*(1.-2.*XC(I)/C)
      SQ=SQRT(1+DETADX**2)
      ENX(I)= -DETADX/SQ
 1    ENZ(I)= 1./SQ
C
C     INFLUENCE COEFFICIENTS
C
      DO 3 I=1,N
      DO 2 J=1,N
      CALL VOR2D(XC(I),ZC(I),X(J),Z(J),1.0,U,W)
      A(I,J)=U*ENX(I)+W*ENZ(I)
 2    CONTINUE
C     THE RHS VECTOR IS PLACED IN THE GAMMA VECTOR
      GAMMA(I)=-UINF*ENX(I)-WINF*ENZ(I)
 3    CONTINUE
C
C     SOLUTION OF THE PROBLEM: RHS(I)=A(I,J)*GAMMA(I)
C
      CALL DECOMP(N,52,A,IP)
      CALL SOLVER(N,52,A,GAMMA,IP)
C
C     AERODYNAMIC LOADS
C
      BL=0.0
      DO 4 I=1,N
      DL(I)=RO*V*GAMMA(I)
      DCP(I)=DL(I)/DX/QUE
C     DCP1 IS THE ANALYTIC SOLUTION
      DD=32.*EPSILON/C*SQRT(X(I)/C*(1.-X(I)/C))
      DCP1(I)=4.*SQRT((C-X(I))/X(I))*ALFA+DD
 4    BL=BL+DL(I)
      CL=BL/(QUE*C)
      CL1=2.*PAY*(ALFA+2*EPSILON/C)
C     CL1, DCP1 - ARE THE EXACT SOLUTIONS
C
C     OUTPUT
      WRITE(6,14)
      WRITE(6,15) V,CL,CL1,N,ALFA1
      DO 5 I=1,N
 5    WRITE(6,16)I,X(I),DCP(I),DCP1(I)
C
 14   FORMAT( ' THIN AIRFOIL WITH ELLIPTIC CAMBER ')
 15   FORMAT( ' V=',F7.1,3X,'CL=',F7.3,3X,'CL(EXACT)=',F7.3,3X,
     * 'N= ',I6,3X,'ALPHA= ',F6.1)
 16   FORMAT( I5,3X,'X=',F8.2,5X,'DCP=',F8.2,3X,'DCP(EXACT)=',5F6.2)
C
C     PLOTTER OUTPUT IS PLACED HERE (e.g. DCP AND DCP1 - VS - X/C)
C
      STOP
      END
C
      SUBROUTINE VOR2D(X,Z,X1,Z1,GAMMA,U,W)
C     CALCULATES INFLUENCE OF VORTEX AT (X1,Z1)
      PAY=3.141592654
      U=0.0
      W=0.0
      RX=X-X1
      RZ=Z-Z1
      R=SQRT(RX**2+RZ**2)
      IF(R.LT.0.001) GOTO 1
      V=0.5/PAY*GAMMA/R
      U=V*(RZ/R)
      W=V*(-RX/R)
 1    CONTINUE
      RETURN
      END
C
      SUBROUTINE DECOMP(N,NDIM,A,IP)
      REAL A(NDIM,NDIM),T
      INTEGER IP(NDIM)
C     MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION.
C     N = ORDER OF MATRIX. NDIM = DECLARED DIMENSION OF ARRAY A.
C     A = MATRIX TO BE TRIANGULARIZED.
C     IP(K) , K .LT. N = INDEX OF K-TH PIVOT ROW.
C
      IP(N) = 1
      DO 6 K = 1, N
      IF(K.EQ.N) GOTO 5
      KP1 = K + 1
      M = K
      DO 1 I = KP1, N
      IF( ABS(A(I,K)).GT.ABS(A(M,K))) M=I
 1    CONTINUE
      IP(K) = M
      IF(M.NE.K) IP(N) = -IP(N)
      T = A(M,K)
      A(M,K) = A(K,K)
      A(K,K) = T
      IF(T.EQ.0.E0) GO TO 5
      DO 2 I = KP1, N
 2    A(I,K) = -A(I,K)/T
      DO 4 J = KP1, N
      T = A(M,J)
      A(M,J) = A(K,J)
      A(K,J) = T
      IF(T .EQ. 0.E0) GO TO 4
      DO 3 I = KP1, N
 3    A(I,J) = A(I,J) + A(I,K)*T
 4    CONTINUE
 5    IF(A(K,K) .EQ. 0.E0) IP(N) = 0
 6    CONTINUE
      RETURN
      END

      SUBROUTINE SOLVER(N,NDIM,A,B,IP)
      REAL A(NDIM,NDIM), B(NDIM), T
      INTEGER IP(NDIM)
C     SOLUTION OF LINEAR SYSTEM, A*X = B.
C     N = ORDER OF MATRIX.
C     NDIM = DECLARED DIMENSION OF THE ARRAY A.
C     B = RIGHT HAND SIDE VECTOR.
C     IP = PIVOT VECTOR OBTAINED FROM SUBROUTINE DECOMP.
C     B = SOLUTION VECTOR, X.
C
      IF(N.EQ.1) GOTO 9
      NM1 = N - 1
      DO 7 K = 1, NM1
      KP1 = K + 1
      M = IP(K)
      T = B(M)
      B(M) = B(K)
      B(K) = T
      DO 7 I = KP1, N
7     B(I) = B(I) + A(I,K)*T
      DO 8 KB = 1, NM1
      KM1 = N - KB
      K = KM1 + 1
      B(K) = B(K)/A(K,K)
      T = -B(K)
      DO 8 I = 1, KM1
8     B(I) = B(I) + A(I,K)*T
9     B(1) = B(1)/A(1,1)
      RETURN
      END


! =====================================================================
! subroutine SM
!
! This subroutine corrects the wavefunction at each time step using the
! Sherman-Morrison algorithm to account for the periodic boundary
! conditions of the polar coordinate system. Note that this subroutine
! does not directly solve the set of linear equations required by the
! Sherman-Morrison algorithm, it merely uses the already computed
! solutions to complete the wavefunction correction.
! ---------------------------------------------------------------------
      subroutine SM(nP,W,Z,US)
      implicit none

      integer :: nP
      double complex :: W(nP)
      double complex :: Z(nP)
      double complex :: US(nP)

      integer :: i
      double complex :: d
      double complex :: dDEN
      double complex :: dNUM

      dDEN = dcmplx(0.0d0,0.0d0)
      dNUM = dcmplx(0.0d0,0.0d0)

      do i = 1, nP
         dDEN = dDEN + Z(i)*W(i)
         dNUM = dNUM + Z(i)*US(i)
      enddo
      dDEN = dcmplx(1.0d0,0.0d0) - dDEN

      d = dNUM/dDEN

      do i = 1, nP
         US(i) = US(i) + d*W(i)
      enddo

      return
      end
! =====================================================================


!##############################################################################
!# ****************************************************************************
!# <name> basicgeometry </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains the basic entity of the whole FEAT world: a point,
!# a coordinate system and a set of routines to maintain that.
!#
!# The following routines can be found in this module:
!#
!#  1.) bgeom_initCoordSys2D, bgeom_initCoordSys3D
!#      -> Creates a 2D/3D coordinate system from an optionally given origin,
!#         rotation and scaling factor.
!#
!#  2.) bgeom_transformPoint2D
!#      -> Transforms a 2D point with coordinates relative to a given
!#         coordinate system to world coordinates.
!#
!#  3.) bgeom_transformBackPoint2D
!#      -> Transforms a 2D point with world coordinates to coordinates relative
!#         to a given coordinate system.
!#
!#  4.) bgeom_transformPoint3D
!#      -> Transforms a 3D point with coordinates relative to a given
!#         coordinate system to world coordinates.
!#
!#  5.) bgeom_transformBackPoint3D
!#      -> Transforms a 3D point with world coordinates to coordinates relative
!#         to a given coordinate system.

!# </purpose>
!##############################################################################

module basicgeometry

!$ use omp_lib
  use fsystem

  implicit none

  private

!<constants>

!<constantblock description="Dimension constants">

  ! Dimension constant for 1D triangulations.
  integer, parameter, public :: NDIM1D = 1

  ! Dimension constant for 2D triangulations.
  integer, parameter, public :: NDIM2D = 2

  ! Dimension constant for 3D triangulations.
  integer, parameter, public :: NDIM3D = 3

!</constantblock>

!<constantblock description="Element shape identifiers">
  ! Unknown shape
  integer(I32), parameter, public :: BGEOM_SHAPE_UNKNOWN = 0_I32

  ! Line shape (1D)
  integer(I32), parameter, public :: BGEOM_SHAPE_LINE  = 1000002_I32

  ! Triangle shape (2D)
  integer(I32), parameter, public :: BGEOM_SHAPE_TRIA  = 2000303_I32

  ! Quadrilateral shape (2D)
  integer(I32), parameter, public :: BGEOM_SHAPE_QUAD  = 2000404_I32

  ! Tetrahedron shape (3D)
  integer(I32), parameter, public :: BGEOM_SHAPE_TETRA = 3040604_I32

  ! Hexahedron shape (3D)
  integer(I32), parameter, public :: BGEOM_SHAPE_HEXA  = 3061208_I32

  ! Pyramid shape (3D)
  integer(I32), parameter, public :: BGEOM_SHAPE_PYRA  = 3050805_I32

  ! Prism shape (3D)
  integer(I32), parameter, public :: BGEOM_SHAPE_PRISM = 3050906_I32

!</constantblock>

!</constants>

  !<types>

  !<typeblock>

  ! The point structure for 2D points.
  type t_point2D

    ! X-coordinate
    real(DP) :: X

    ! Y-coordinate
    real(DP) :: Y

  end type

  public :: t_point2D

  !<typeblock>

  !</typeblock>

  ! The point structure for 3D points.
  type t_point3D

    ! X-coordinate
    real(DP) :: X

    ! Y-coordinate
    real(DP) :: Y

    ! Z-coordinate
    real(DP) :: Z

  end type

  public :: t_point3D

  !</typeblock>

  !<typeblock>

  ! The point structure for regular 2D coordinate systems, consisting of
  ! a rotated X- and Y-axes
  type t_coordinateSystem2D

    ! Coordinates of the origin
    real(DP), dimension(2) :: Dorigin = (/0.0_DP,0.0_DP/)

    ! Rotation angle; 0..2*PI
    real(DP) :: drotation = 0.0_DP

    ! precalculated value: sin(rotation); for quicker calculations
    real(DP) :: dsin_rotation = 0.0_DP

    ! precalculated value: cos(rotation); for quicker calculations
    real(DP) :: dcos_rotation = 1.0_DP

    ! scaling factor of the coordinate system; usually = 1.0
    real(DP) :: dscalingFactor = 1.0_DP

  end type

  public :: t_coordinateSystem2D

  !</typeblock>

  !<typeblock>

  ! The point structure for regular 3D coordinate systems, consisting of
  ! a rotated X-, Y-axes and Z-axes
  type t_coordinateSystem3D

    ! Coordinates of the origin
    real(DP), dimension(3) :: Dorigin = (/0.0_dp,0.0_dp,0.0_dp/)

    ! Rotation angle; 0..2*PI
    real(DP) :: drotationX = 0.0_dp

    real(DP) :: drotationY = 0.0_dp

    real(DP) :: drotationZ = 0.0_dp

    ! scaling factor of the coordinate system; usually = 1.0
    real(DP) :: dscalingFactor = 1.0_dp

  end type

    public :: t_coordinateSystem3D

  !</typeblock>

  !</types>

  public :: bgeom_initCoordSys2D
  public :: bgeom_initCoordSys3D
  public :: bgeom_transformPoint2D
  public :: bgeom_transformBackPoint2D
  public :: bgeom_transformPoint3D
  public :: bgeom_transformBackPoint3D

contains

  ! ***************************************************************************

!<subroutine>

  pure subroutine bgeom_initCoordSys2D(rcoordSys, Dorigin, drotation, &
                                       dscalingFactor)

!<description>
  ! Creates a 2D coordinate system from an optionally given origin, rotation
  ! and scaling factor.
!</description>

!<input>
  ! OPTIONAL: The origin of the coordinate system.
  ! Set to (/ 0.0_DP, 0.0_DP /) if not given.
  real(DP), dimension(:), optional,    intent(in)  :: Dorigin

  ! OPTIONAL: The rotation angle of the coordinate system.
  ! Angle range: 0..2*PI
  ! Set to 0.0_DP if not given.
  real(DP), optional,                  intent(in)  :: drotation

  ! The scaling factor. Should be != 0.0_DP
  ! Set to 1.0_DP if not given.
  real(DP), optional,                  intent(in)  :: dscalingFactor

!</input>

!<output>
  ! A t_coordinateSystem2D structure to be written.
  type(t_coordinateSystem2D),          intent(out) :: rcoordSys

!</output>

!</subroutine>

    ! Set the origin, if given.
    if (present(Dorigin)) then
      rcoordSys%Dorigin = (/ Dorigin(1), Dorigin(2) /)
    else
      rcoordSys%Dorigin = (/ 0.0_DP, 0.0_DP /)
    end if

    ! Set the rotation, if given.
    if (present(drotation)) then

      rcoordSys%drotation = drotation

      ! Calculate SIN and COS of rotation angle
      rcoordSys%dsin_rotation = sin(drotation)
      rcoordSys%dcos_rotation = cos(drotation)

    else

      rcoordSys%drotation = 0.0_DP

      ! Set SIN and COS values
      rcoordSys%dsin_rotation = 0.0_DP
      rcoordSys%dcos_rotation = 1.0_DP

    end if

    ! Set the scaling factor, if given.
    if (present(dscalingFactor)) then
      rcoordSys%dscalingFactor = dscalingFactor
    else
      rcoordSys%dscalingFactor = 1.0_DP
    endif

    ! That is it

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine bgeom_transformPoint2D(rcoordSys, DpointIn, DpointOut)

!<description>
  ! Transforms a given 2D point with coordinates relative to the given
  ! coordinate system to world coordinates.
!</description>

!<input>
  ! The 2D coordinate system that is to be applied to the given point.
  type(t_coordinateSystem2D),  intent(in)  :: rcoordSys

  ! The 2D point that is to be transformed.
  real(DP), dimension(:),      intent(in)  :: DpointIn
!</input>

!<output>
  ! The transformed 2D point.
  real(DP), dimension(:),      intent(out) :: DpointOut
!</output>

!</subroutine>

    ! Check if the rotation of the coordinate system is non-zero.
    if (rcoordSys%drotation .ne. 0.0_DP) then

      ! Apply rotation to the input coordinates.
      DpointOut(1) = (rcoordSys%dcos_rotation * DpointIn(1)) - &
                     (rcoordSys%dsin_rotation * DpointIn(2))
      DpointOut(2) = (rcoordSys%dsin_rotation * DpointIn(1)) + &
                     (rcoordSys%dcos_rotation * DpointIn(2))

    else

      ! No rotation in the coordinate system, so simply copy the input coords.
      DpointOut(1) = DpointIn(1)
      DpointOut(2) = DpointIn(2)

    end if

    ! Now scale the given coordinates by the scaling factor and translate them
    ! by the origin of our coordinate system.
    DpointOut(1) = (rcoordSys%dscalingFactor * DpointOut(1)) + &
                    rcoordSys%Dorigin(1)
    DpointOut(2) = (rcoordSys%dscalingFactor * DpointOut(2)) + &
                    rcoordSys%Dorigin(2)

    ! That is it!

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine bgeom_transformBackPoint2D(rcoordSys, DpointIn, DpointOut)

!<description>
  ! Transform a 2D point given in world coordinates to coordinates relative
  ! to a given 2D coordinate system.
  ! This subroutine is the inverse routine of bgeom_transformPoint2D.
!</description>

!<input>
  ! The 2D coordinate system of our input point.
  type(t_coordinateSystem2D), intent(in)  :: rcoordSys

  ! The 2D point that is to be transformed, relative to the given coordinate
  ! system.
  real(DP), dimension(:),     intent(in)  :: DpointIn
!</input>

!<output>
  ! The transformed 2D point, in world coordinates.
  real(DP), dimension(:),     intent(out) :: DpointOut
!</output>

!</subroutine>

    ! local variables
    real(DP) :: X,Y

    ! Translate the given point by the negatives of our coordinate system
    ! origin.
    X = DpointIn(1) - rcoordSys%Dorigin(1)
    Y = DpointIn(2) - rcoordSys%Dorigin(2)

    ! Now scale the point by the inverse of our coordinate system sclaing
    ! factor, of course only if it is non-zero ...
    if (rcoordSys%dscalingFactor .ne. 0.0_DP) then

      X = X / rcoordSys%dscalingFactor
      Y = Y / rcoordSys%dscalingFactor

    else

      ! ... or set the result to zero and exit subroutine otherwise.
      DpointOut(1) = 0.0_DP
      DpointOut(2) = 0.0_DP
      return

    endif

    ! Check if the rotation of the coordinate system is non-zero.
    if (rcoordSys%drotation .ne. 0.0_DP) then

      ! Apply rotation to the input coordinates.
      DpointOut(1) = ( rcoordSys%dcos_rotation * X) + (rcoordSys%dsin_rotation * Y)
      DpointOut(2) = (-rcoordSys%dsin_rotation * X) + (rcoordSys%dcos_rotation * Y)

    else

      ! No rotation in the coordinate system, so simply copy the input coords.
      DpointOut(1) = X
      DpointOut(2) = Y

    end if

    ! That is it

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine bgeom_initCoordSys3D(rcoordSys, Dorigin, drotationX, drotationY,&
                                       drotationZ, dscalingFactor)

!<description>
  ! Creates a 3D coordinate system from an optionally given origin, rotation angles
  ! and scaling factor.
!</description>

!<input>
  ! OPTIONAL: The origin of the coordinate system.
  ! Set to (/ 0.0_dp, 0.0_dp, 0.0_dp /) if not given.
  real(DP), dimension(:), optional,    intent(in)  :: Dorigin

  ! OPTIONAL: The rotation angles of the coordinate system.
  ! Angle range: 0..2*PI
  ! Set to 0.0_DP if not given.
  real(DP), optional,                  intent(in)  :: drotationX
  real(DP), optional,                  intent(in)  :: drotationY
  real(DP), optional,                  intent(in)  :: drotationZ

  ! The scaling factor. Should be != 0.0_DP
  ! Set to 1.0_DP if not given.
  real(DP), optional,                  intent(in)  :: dscalingFactor

!</input>

!<output>
  ! A t_coordinateSystem3D structure to be written.
  type(t_coordinateSystem3D),          intent(out) :: rcoordSys

!</output>

!</subroutine>

    ! Set the origin, if given.
    if (present(Dorigin)) then
      rcoordSys%Dorigin = (/ Dorigin(1), Dorigin(2), Dorigin(3) /)
    else
      rcoordSys%Dorigin = (/ 0.0_dp, 0.0_dp, 0.0_dp /)
    end if

    ! Set the rotation, if given.
    if (present(drotationX)) then
      rcoordSys%drotationX = drotationX
    else
      rcoordSys%drotationX = 0.0_DP
    end if

    ! Set the rotation, if given.
    if (present(drotationY)) then
      rcoordSys%drotationY = drotationY
    else
      rcoordSys%drotationY = 0.0_DP
    end if

    ! Set the rotation, if given.
    if (present(drotationZ)) then
      rcoordSys%drotationZ = drotationZ
    else
      rcoordSys%drotationZ = 0.0_DP
    end if

    ! Set the scaling factor, if given.
    if (present(dscalingFactor)) then
      rcoordSys%dscalingFactor = dscalingFactor
    else
      rcoordSys%dscalingFactor = 1.0_DP
    endif

    ! That is it

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine bgeom_transformPoint3D(rcoordSys, DpointIn, DpointOut)

!<description>
  ! Transforms a 3D point in model coordinates to world coordinates
  ! This routine may be inefficient if a large number of of points is to
  ! be transformed. Then a matrix based transformation would be more efficient.
  ! But this would require a rewriting of the mechanism how routines, that call
  ! this function(i.e. geom_isingeometry) work.
!</description>

!<input>
  ! The 3D coordinate system that is to be applied to the given point.
  type(t_coordinateSystem3D),  intent(in)  :: rcoordSys

  ! The 3D point that is to be transformed.
  real(DP), dimension(:),      intent(in)  :: DpointIn
!</input>

!<output>
  ! The transformed 3D point.
  real(DP), dimension(:),      intent(out) :: DpointOut
!</output>

!</subroutine>

  real(dp) :: sx,sy,sz,cx,cy,cz,x1,y1,z1,x2,y2,z2

  ! Check if the rotation of the coordinate system is non-zero.
  if (rcoordSys%drotationX .ne. 0.0_DP) then

    ! setup
    sx = sin(rcoordSys%drotationX)
    cx = cos(rcoordSys%drotationX)
    sy = sin(rcoordSys%drotationY)
    cy = cos(rcoordSys%drotationY)
    sz = sin(rcoordSys%drotationZ)
    cz = cos(rcoordSys%drotationZ)

    x1 =  DpointIn(1) * cz +  DpointIn(2) * sz
    y1 =  DpointIn(2) * cz -  DpointIn(1) * sz
    z1 =  DpointIn(3)
    x2 = x1 * cy + z1 * sy
    y2 = z1
    z2 = z1 * cy - x1 * sy
    DpointOut(1) = x2
    DpointOut(2) = y2 * cx + z1 * sx
    DpointOut(3) = z2 * cx - x1 * sx

  else

    ! No rotation in the coordinate system, so simply copy the input coords.
    DpointOut(1) = DpointIn(1)
    DpointOut(2) = DpointIn(2)
    DpointOut(3) = DpointIn(3)

  end if

  ! Now scale the given coordinates by the scaling factor and translate them
  ! by the origin of our coordinate system.
  DpointOut(1) = (rcoordSys%dscalingFactor * DpointOut(1)) + &
                  rcoordSys%Dorigin(1)
  DpointOut(2) = (rcoordSys%dscalingFactor * DpointOut(2)) + &
                  rcoordSys%Dorigin(2)
  DpointOut(3) = (rcoordSys%dscalingFactor * DpointOut(3)) + &
                  rcoordSys%Dorigin(3)

  ! That is it!

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine bgeom_transformBackPoint3D(rcoordSys, DpointIn, DpointOut)

!<description>
  ! Transform a 3d point from world coordinates to model coordinates
!</description>

!<input>
  ! The 3D coordinate system of our input point.
  type(t_coordinateSystem3D), intent(in)  :: rcoordSys

  ! The 3D point that is to be transformed, relative to the given coordinate
  ! system.
  real(DP), dimension(:),     intent(in)  :: DpointIn
!</input>

!<output>
  ! The transformed 3D point, in world coordinates.
  real(DP), dimension(:),     intent(out) :: DpointOut
!</output>

!</subroutine>

  ! local variables
  real(DP) :: X,Y,Z

  real(dp) :: sx,sy,sz,cx,cy,cz,x1,y1,z1,x2,y2,z2

  ! Translate the given point by the negatives of our coordinate system
  ! origin.
  X = DpointIn(1) - rcoordSys%Dorigin(1)
  Y = DpointIn(2) - rcoordSys%Dorigin(2)
  Z = DpointIn(3) - rcoordSys%Dorigin(3)

  ! Now scale the point by the inverse of our coordinate system sclaing
  ! factor, of course only if it is non-zero ...
  if (rcoordSys%dscalingFactor .ne. 0.0_DP) then

    X = X / rcoordSys%dscalingFactor
    Y = Y / rcoordSys%dscalingFactor
    Z = Z / rcoordSys%dscalingFactor

  else

    ! ... or set the result to zero and exit subroutine otherwise.
    DpointOut(1) = 0.0_DP
    DpointOut(2) = 0.0_DP
    DpointOut(3) = 0.0_DP
    return

  endif

  ! Check if the rotation of the coordinate system is non-zero.
  if (rcoordSys%drotationX .ne. 0.0_DP) then

    ! setup
    sx = sin(-rcoordSys%drotationX)
    cx = cos(-rcoordSys%drotationX)
    sy = sin(-rcoordSys%drotationY)
    cy = cos(-rcoordSys%drotationY)
    sz = sin(-rcoordSys%drotationZ)
    cz = cos(-rcoordSys%drotationZ)

    x1 =  X * cz + Y * sz
    y1 =  Y * cz - X * sz
    z1 =  Z
    x2 = x1 * cy + z1 * sy
    y2 = z1
    z2 = z1 * cy - x1 * sy
    DpointOut(1) = x2
    DpointOut(2) = y2 * cx + z1 * sx
    DpointOut(3) = z2 * cx - x1 * sx

  else

    ! No rotation in the coordinate system, so simply copy the input coords.
    DpointOut(1) = X
    DpointOut(2) = Y
    DpointOut(3) = Z

  end if

  end subroutine

  ! ***************************************************************************

end module


      subroutine splopt ( tau, n, k, scrtch, t, iflag )
c  from  * a practical guide to splines *  by c. de boor
calls bsplvb, banfac/slv
computes the knots  t  for the optimal recovery scheme of order  k
c  for data at	tau(i), i=1,...,n .
c
c******  i n p u t  ******
c  tau.....array of length  n , containing the interpolation points.
c     a s s u m e d  to be nondecreasing, with tau(i).lt.tau(i+k),all i.
c  n.....number of data points .
c  k.....order of the optimal recovery scheme to be used .
c
c******  w o r k  a r r a y  *****
c  scrtch.....array of length  (n-k)(2k+3) + 5k + 3 . the various
c	 contents are specified in the text below .
c
c******  o u t p u t  ******
c  iflag.....integer indicating success (=1) or failure (=2) .
c     if iflag = 1, then
c  t.....array of length  n+k  containing the optimal knots ready for
c	 use in optimal recovery. specifically,  t(1) = ... = t(k) =
c	 tau(1)  and  t(n+1) = ... = t(n+k) = tau(n) , while the  n-k
c	 interior knots  t(k+1), ..., t(n)  are calculated as described
c	 below under  *method* .
c     if iflag = 2, then
c	 k .lt. 3, or n .lt. k, or a certain linear system was found to
c	 be singular.
c
c******  p r i n t e d	o u t p u t  ******
c  a comment will be printed in case  ilfag = 2  or newton iterations
c  failed to converge in  n e w t m x  iterations .
c
c******  m e t h o d  ******
c     the (interior) knots  t(k+1), ..., t(n)  are determined by newtons
c  method in such a way that the signum function which changes sign at
c   t(k+1), ..., t(n)  and nowhere else in  (tau(1),tau(n)) is orthogon-
c  al to the spline space  spline( k , tau )  on that interval .
c     let  xi(j)  be the current guess for  t(k+j), j=1,...,n-k. then
c  the next newton iterate is of the form
c	       xi(j)  +  (-)**(n-k-j)*x(j)  ,  j=1,...,n-k,
c  with  x  the solution of the linear system
c			 c*x  =  d  .
c  here,  c(i,j) = b(i)(xi(j)), all j, with  b(i)  the i-th b-spline of
c  order  k  for the knot sequence  tau , all i, and  d  is the vector
c  given by  d(i) = sum( -a(j) , j=i,...,n )*(tau(i+k)-tau(i))/k, all i,
c  with  a(i) = sum ( (-)**(n-k-j)*b(i,k+1,tau)(xi(j)) , j=1,...,n-k )
c  for i=1,...,n-1, and  a(n) = -.5 .
c     (see chapter  xiii  of text and references there for a derivation)
c     the first guess for  t(k+j)  is  (tau(j+1)+...+tau(j+k-1))/(k-1) .
c     iteration terminates if  max(abs(x(j))) .lt. t o l  , with
c		  t o l  =  t o l r t e *(tau(n)-tau(1))/(n-k) ,
c  or else after  n e w t m x  iterations , currently,
c		  newtmx, tolrte / 10, .000001
c
      integer iflag,k,n,   i,id,index,j,km1,kpk,kpkm1,kpn,kp1,l,left
     *,leftmk,lenw,ll,llmax,llmin,na,nb,nc,nd,newtmx,newton,nmk,nmkm1,nx
      real scrtch(1),t(1),tau(n),   del,delmax,floatk,sign,signst,sum
     *				   ,tol,tolrte,xij
c     dimension scrtch((n-k)*(2*k+3)+5*k+3), t(n+k)
current fortran standard makes it impossible to specify the precise dim-
c  ensions of  scrtch  and  t  without the introduction of otherwise
c  superfluous additional arguments .
      data newtmx,tolrte / 10,.000001/
      nmk = n-k
      if (nmk)				1,56,2
    1 print 601,n,k
  601 format(13h argument n =,i4,29h in  splopt  is less than k =,i3)
					go to 999
    2 if (k .gt. 2)			go to 3
      print 602,k
  602 format(13h argument k =,i3,27h in  splopt  is less than 3)
					go to 999
   3  nmkm1 = nmk - 1
      floatk = k
      kpk = k+k
      kp1 = k+1
      km1 = k-1
      kpkm1 = kpk-1
      kpn = k+n
      signst = -1.
      if (nmk .gt. (nmk/2)*2)  signst = 1.
c  scrtch(i) = tau-extended(i), i=1,...,n+k+k
      nx = n+kpk+1
c  scrtch(i+nx) = xi(i),i=0,...,n-k+1
      na = nx + nmk + 1
c  scrtch(i+na) = -a(i), i=1,...,n
      nd = na + n
c  scrtch(i+nd) = x(i) or d(i), i=1,...,n-k
      nb = nd + nmk
c  scrtch(i+nb) = biatx(i),i=1,...,k+1
      nc = nb + kp1
c  scrtch(i+(j-1)*(2k-1) + nc) = w(i,j) = c(i-k+j,j), i=j-k,...,j+k,
c						      j=1,...,n-k.
      lenw = kpkm1*nmk
c  extend  tau	to a knot sequence and store in scrtch.
      do 5 j=1,k
	 scrtch(j) = tau(1)
    5	 scrtch(kpn+j) = tau(n)
      do 6 j=1,n
    6	 scrtch(k+j) = tau(j)
c  first guess for  scrtch (.+nx)  =  xi .
      scrtch(nx) = tau(1)
      scrtch(nmk+1+nx) = tau(n)
      do 10 j=1,nmk
	 sum = 0.
	 do 9 l=1,km1
    9	    sum = sum + tau(j+l)
   10	 scrtch(j+nx) = sum/float(km1)
c  last entry of  scrtch (.+na)  =  - a  is always ...
      scrtch(n+na) = .5
c  start newton iteration.
      newton = 1
      tol = tolrte*(tau(n) - tau(1))/float(nmk)
c  start newton step
compute the 2k-1 bands of the matrix c and store in scrtch(.+nc),
c  and compute the vector  scrtch(.+na) = -a.
   20 do 21 i=1,lenw
   21	 scrtch(i+nc) = 0.
      do 22 i=2,n
   22	 scrtch(i-1+na) = 0.
      sign = signst
      left = kp1
      do 28 j=1,nmk
	 xij = scrtch(j+nx)
   23	    if (xij .lt. scrtch(left+1))go to 25
	    left = left + 1
	    if (left .lt. kpn)		go to 23
	    left = left - 1
   25	 call bsplvb(scrtch,k,1,xij,left,scrtch(1+nb))
c	 the tau sequence in scrtch is preceded by  k  additional knots
c	 therefore,  scrtch(ll+nb)  now contains  b(left-2k+ll)(xij)
c	 which is destined for	c(left-2k+ll,j), and therefore for
c	     w(left-k-j+ll,j)= scrtch(left-k-j+ll + (j-1)*kpkm1 + nc)
c	 since we store the 2k-1 bands of  c  in the 2k-1  r o w s  of
c	 the work array w, and	w  in turn is stored in  s c r t c h ,
c	 with  w(1,1) = scrtch(1 + nc) .
c	     also, c  being of order  n-k, we would want  1 .le.
c	 left-2k+ll .le. n-k  or
c	    llmin = 2k-left  .le.  ll  .le.  n-left+k = llmax .
	 leftmk = left-k
	 index = leftmk-j + (j-1)*kpkm1 + nc
	 llmin = max0(1,k-leftmk)
	 llmax = min0(k,n-leftmk)
	 do 26 ll=llmin,llmax
   26	    scrtch(ll+index) = scrtch(ll+nb)
	 call bsplvb(scrtch,kp1,2,xij,left,scrtch(1+nb))
	 id = max0(0,leftmk-kp1)
	 llmin = 1 - min0(0,leftmk-kp1)
	 do 27 ll=llmin,kp1
	    id = id + 1
   27	     scrtch(id+na) = scrtch(id+na) - sign*scrtch(ll+nb)
   28	 sign = -sign
      call banfac(scrtch(1+nc),kpkm1,nmk,km1,km1,iflag)
					go to (45,44),iflag
   44 print 644
  644 format(32h c in  splopt  is not invertible)
					return
compute  scrtch (.+nd) =  d  from  scrtch (.+na) = - a .
   45 i=n
   46	 scrtch(i-1+na) = scrtch(i-1+na) + scrtch(i+na)
	 i = i-1
	 if (i .gt. 1)			go to 46
      do 49 i=1,nmk
   49	 scrtch(i+nd) = scrtch(i+na)*(tau(i+k)-tau(i))/floatk
compute  scrtch (.+nd) =  x .
      call banslv(scrtch(1+nc),kpkm1,nmk,km1,km1,scrtch(1+nd))
compute  scrtch (.+nd) = change in  xi . modify, if necessary, to
c  prevent new	xi  from moving more than 1/3 of the way to its
c  neighbors. then add to  xi  to obtain new  xi  in scrtch(.+nx).
      delmax = 0.
      sign = signst
      do 53 i=1,nmk
	 del = sign*scrtch(i+nd)
	 delmax = amax1(delmax,abs(del))
	 if (del .gt. 0.)		go to 51
	 del = amax1(del,(scrtch(i-1+nx)-scrtch(i+nx))/3.)
					go to 52
   51	 del = amin1(del,(scrtch(i+1+nx)-scrtch(i+nx))/3.)
   52	 sign = -sign
   53	 scrtch(i+nx) = scrtch(i+nx) + del
call it a day in case change in  xi  was small enough or too many
c  steps were taken.
      if (delmax .lt. tol)		go to 54
      newton = newton + 1
      if (newton .le. newtmx)		go to 20
      print 653,newtmx
  653 format(33h no convergence in  splopt  after,i3,14h newton steps.)
   54 do 55 i=1,nmk
   55	 t(k+i) = scrtch(i+nx)
   56 do 57 i=1,k
	 t(i) = tau(1)
   57	 t(n+i) = tau(n)
					return
  999 iflag = 2
					return
      end


MODULE GreyVariables
!-----------------------------------------------------------------------
!
!    File:         GreyVariables
!    Module:       GreyVariables
!    Type:         Module
!    Author:       R. Chu, Dept of Physics, UTK
!
!    Date:         8/21/16
!
!    Purpose:
!      Subroutines needed for GreyMoment_Number/Energy
!                        and  GreyOpacity_Number/Energy
!    Mudules used:
!      wlKindModule
!      gaquad
!-----------------------------------------------------------------------

  USE wlKindModule, ONLY: dp
  USE B85_Absorption
  USE B85_scattIso

  PUBLIC :: &
    GreyMomentWithGaussianQuadrature,&
    GreyOpacityWithGaussianQuadrature

CONTAINS

  SUBROUTINE GreyMomentWithGaussianQuadrature&
                  ( nquad, bb, outcome, func, debug )

  INTEGER, INTENT(in)        :: nquad
  REAL(dp), INTENT(in)       :: bb
  CHARACTER(18), INTENT(in)  :: func
  LOGICAL, INTENT(in)        :: debug

  REAL(dp), INTENT(out)      :: outcome

  INTEGER, PARAMETER         :: npiece = 47
  REAL(dp), DIMENSION(nquad) :: roots, weights, FD
  REAL(dp), DIMENSION(npiece):: lim
  INTEGER                    :: ii, jj
  REAL(dp)                   :: llim, ulim

  IF (debug) THEN
    PRINT*,"Calculating ", func
    PRINT*,"with bb = ",bb
  END IF

  outcome = 0.0_dp
  lim(1) = 0.0_dp

  DO jj = 1,10
     lim(jj+1) = lim(jj) + 0.1_dp
  END DO
  DO jj = 12, 20
     lim(jj) = lim(jj-1) + 1.0_dp
  END DO
  DO jj = 21, 29
     lim(jj) = lim(jj-1) + 10.0_dp
  END DO
  DO jj = 30, 38
     lim(jj) = lim(jj-1) + 100.0_dp
  END DO
  DO jj = 39, 47
     lim(jj) = lim(jj-1) + 1000.0_dp
  END DO

  DO jj = 1,(npiece-1)

    llim = lim(jj)
    ulim = lim(jj+1)

    CALL gaquad( nquad, roots, weights, llim, ulim )

    DO ii = 1, nquad

      IF (func == "GreyMoment_Number  ") THEN

        FD(ii) = Number_FD( roots(ii), bb)
        outcome = outcome + weights(ii) * &
                  Number_FD( roots(ii), bb)

      ELSE IF (func == "GreyMoment_Energy  ") THEN

        FD(ii) = Energy_FD( roots(ii), bb)
        outcome = outcome + weights(ii) * &
                  Energy_FD( roots(ii), bb)

      END IF

    END DO ! ii (nquad)

  END DO ! jj

  IF (debug) THEN
    WRITE(*,'(A24,F7.1,A2,F7.1,A1)')&
        " Integration domain is [",lim(1),", ",lim(47),"]"
    print*,"divided into", lim
    PRINT*, "with nquad=", nquad
    PRINT*, "and the outcome is", outcome
  END IF

  END SUBROUTINE GreyMomentWithGaussianQuadrature

  SUBROUTINE GreyOpacityWithGaussianQuadrature_NuEAb&
                  ( nquad, bb, &
                    rho, T, Z, A, chem_e, chem_n,&
                    chem_p, xheavy, xn, xp,&
                    outcome, func, debug )
  INTEGER, INTENT(in)        :: nquad
  REAL(dp), INTENT(in)       :: bb, rho, T, Z, A, &
                                chem_e, chem_n, &
                                chem_p, xheavy, xn,&
                                xp
  CHARACTER(18), INTENT(in)  :: func
  LOGICAL, INTENT(in)        :: debug

  REAL(dp), INTENT(out)      :: outcome

  INTEGER, PARAMETER         :: npiece = 47
  REAL(dp), DIMENSION(nquad) :: roots, weights, opacity
  REAL(dp), DIMENSION(npiece):: lim
  INTEGER                    :: ii, jj
  REAL(dp)                   :: llim, ulim

  IF (debug) THEN
    PRINT*,"Calculating ", func
    PRINT*,"with bb =", bb
  END IF

  outcome = 0.0_dp
  lim(1) = 0.0_dp

  DO jj = 1,10
     lim(jj+1) = lim(jj) + 0.1_dp
  END DO
  DO jj = 12, 20
     lim(jj) = lim(jj-1) + 1.0_dp
  END DO
  DO jj = 21, 29
     lim(jj) = lim(jj-1) + 10.0_dp
  END DO
  DO jj = 30, 38
     lim(jj) = lim(jj-1) + 100.0_dp
  END DO
  DO jj = 39, 47
     lim(jj) = lim(jj-1) + 1000.0_dp
  END DO

  DO jj = 1,(npiece-1)

    llim = lim(jj)
    ulim = lim(jj+1)

    CALL gaquad( nquad, roots, weights, llim, ulim )

    DO ii = 1, nquad

      opacity(ii) = TotalNuEAbsorption(roots(ii), rho, T, Z, A,&
                      chem_e, chem_n, chem_p, &
                      xheavy, xn, xp )

      IF (func == "GreyOpacity_Number ") THEN

        outcome = outcome + weights(ii) * &
                  Number_FD( roots(ii), bb) * opacity(ii)

      ELSE IF (func == "GreyOpacity_Energy ") THEN

        outcome = outcome + weights(ii) * &
                  Energy_FD( roots(ii), bb) * opacity(ii)

      END IF
    END DO ! ii (nquad)

  END DO ! jj

  IF (debug) THEN
    WRITE(*,'(A24,F7.1,A2,F7.1,A1)') &
        " Integration domain is [",lim(1),", ",lim(47),"]"
    print*,"divided into", lim
    PRINT*, "with nquad=", nquad
   PRINT*, "and the outcome is", outcome
  END IF

  END SUBROUTINE GreyOpacityWithGaussianQuadrature_NuEAb

  SUBROUTINE GreyOpacityWithGaussianQuadrature_scattIso&
                  ( nquad, bb, &
                    rho, T, xh, A, Z, xn, xp, l,&
                    outcome, func, debug )

  USE, INTRINSIC :: ieee_arithmetic, ONLY: IEEE_IS_NAN

  INTEGER, INTENT(in)        :: nquad, l
  REAL(dp), INTENT(in)       :: bb, rho, T, xh, A, Z, xn, xp
  CHARACTER(18), INTENT(in)  :: func
  LOGICAL, INTENT(in)        :: debug

  REAL(dp), INTENT(out)      :: outcome

  INTEGER, PARAMETER         :: npiece = 47
  REAL(dp), DIMENSION(nquad) :: roots, weights, opacity
  REAL(dp), DIMENSION(npiece):: lim
  INTEGER                    :: ii, jj
  REAL(dp)                   :: llim, ulim

  IF (debug) THEN
    PRINT*,"Calculating ", func
    PRINT*,"with bb =", bb
  END IF

  outcome = 0.0_dp
  lim(1) = 0.0_dp

  DO jj = 1,10
     lim(jj+1) = lim(jj) + 0.1_dp
  END DO
  DO jj = 12, 20
     lim(jj) = lim(jj-1) + 1.0_dp
  END DO
  DO jj = 21, 29
     lim(jj) = lim(jj-1) + 10.0_dp
  END DO
  DO jj = 30, 38
     lim(jj) = lim(jj-1) + 100.0_dp
  END DO
  DO jj = 39, 47
     lim(jj) = lim(jj-1) + 1000.0_dp
  END DO

  DO jj = 1,(npiece-1)

    llim = lim(jj)
    ulim = lim(jj+1)

    CALL gaquad( nquad, roots, weights, llim, ulim )

    DO ii = 1, nquad

      opacity(ii) = TotalIsoScatteringKernel&
     ( roots(ii), rho, T, xh, A, Z, xn, xp, l )

      IF (func == "GreyOpacity_Number ") THEN

        outcome = outcome + weights(ii) * &
                  Number_FD( roots(ii), bb) * opacity(ii)

      ELSE IF (func == "GreyOpacity_Energy ") THEN

        outcome = outcome + weights(ii) * &
                  Energy_FD( roots(ii), bb) * opacity(ii)

      END IF
    END DO ! ii (nquad)

      IF ( l == 0 ) THEN

        outcome = outcome * (4.0*pi)

      END IF

  END DO ! jj

  IF (debug) THEN
    WRITE(*,'(A24,F7.1,A2,F7.1,A1)') &
        " Integration domain is [",lim(1),", ",lim(47),"]"
    print*,"divided into", lim
    PRINT*, "with nquad=", nquad
   PRINT*, "and the outcome is", outcome
  END IF

  IF ( IEEE_IS_NAN(outcome) )THEN
   WRITE(*,*)"STOP for data error"
   STOP
  END IF
  END SUBROUTINE GreyOpacityWithGaussianQuadrature_scattIso

!  SUBROUTINE GreyOpacityWithGaussianQuadrature_NES&
!                  ( nquad, bb, &
!                    TMeV, chem_e, l,&
!                    outcome, species, func, debug )
!  INTEGER, INTENT(in)        :: nquad, l, species
!  REAL(dp), INTENT(in)       :: bb, TMeV, chem_e
!  CHARACTER(18), INTENT(in)  :: func
!  LOGICAL, INTENT(in)        :: debug
!
!  REAL(dp), INTENT(out)      :: outcome
!
!  INTEGER, PARAMETER         :: npiece = 47
!  REAL(dp), DIMENSION(nquad) :: roots, weights, opacity
!  REAL(dp), DIMENSION(npiece):: lim
!  INTEGER                    :: ii, jj
!  REAL(dp)                   :: llim, ulim
!
!  IF (debug) THEN
!    PRINT*,"Calculating ", func
!    PRINT*,"with bb =", bb
!  END IF
!
!  outcome = 0.0_dp
!  lim(1) = 0.0_dp
!
!  DO jj = 1,10
!     lim(jj+1) = lim(jj) + 0.1_dp
!  END DO
!  DO jj = 12, 20
!     lim(jj) = lim(jj-1) + 1.0_dp
!  END DO
!  DO jj = 21, 29
!     lim(jj) = lim(jj-1) + 10.0_dp
!  END DO
!  DO jj = 30, 38
!     lim(jj) = lim(jj-1) + 100.0_dp
!  END DO
!  DO jj = 39, 47
!     lim(jj) = lim(jj-1) + 1000.0_dp
!  END DO
!
!  DO jj = 1,(npiece-1)
!
!    llim = lim(jj)
!    ulim = lim(jj+1)
!
!    CALL gaquad( nquad, roots, weights, llim, ulim )
!
!      opacity(ii) = totalNESKernel&
!     ( roots(ii), TMeV, chem_e, l, species )  !!!
!
!    DO ii = 1, nquad
!
!      IF (func == "GreyOpacity_Number ") THEN
!
!        outcome = outcome + weights(ii) * &
!                  Number_FD( roots(ii), bb) * opacity(ii)
!
!      ELSE IF (func == "GreyOpacity_Energy ") THEN
!
!        outcome = outcome + weights(ii) * &
!                  Energy_FD( roots(ii), bb) * opacity(ii)
!
!      END IF
!    END DO ! ii (nquad)
!
!      IF ( l == 0 ) THEN
!
!        outcome = outcome * (4.0*pi)
!
!      END IF
!
!  END DO ! jj
!
!  END SUBROUTINE GreyOpacityWithGaussianQuadrature_NES

!-------------------------------------------------------
!    Declear GrayFunctions
!-------------------------------------------------------

  FUNCTION Number_FD( x, b )

  USE wlKindModule, ONLY: dp
   REAL(dp), INTENT(in)  :: x,b    ! function argument
   REAL(dp)              :: fexp, Number_FD

   Number_FD =  ( x*x )/( fexp(x-b) + 1.0 )

  END FUNCTION Number_FD

  FUNCTION Energy_FD( x, b )

  USE wlKindModule, ONLY: dp

   REAL(dp), INTENT(in)  :: x,b    ! function argument
   REAL(dp)              :: fexp, Energy_FD

   Energy_FD =  ( x*x*x )/( fexp(x-b) + 1.0 )

  END FUNCTION Energy_FD

END MODULE GreyVariables


*=============================================================================*

      SUBROUTINE odrl(nz,z,nw,wl, c,
     $     dtrl)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Compute Rayleigh optical depths as a function of altitude and wavelength =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NZ      - INTEGER, number of specified altitude levels in the working (I)=*
*=            grid                                                           =*
*=  Z       - REAL, specified altitude working grid (km)                  (I)=*
*=  NW      - INTEGER, number of specified intervals + 1 in working       (I)=*
*=            wavelength grid                                                =*
*=  WL      - REAL, vector of lower limits of wavelength intervals in     (I)=*
*=            working wavelength grid                                        =*
*=  C       - REAL, number of air molecules per cm^2 at each specified    (O)=*
*=            altitude layer                                                 =*
*=  DTRL    - REAL, Rayleigh optical depth at each specified altitude     (O)=*
*=            and each specified wavelength                                  =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INCLUDE 'params'

* input:
      INTEGER nw, nz
      REAL wl(kw), z(kz)
      REAL c(kz)

* output:
* Rayleigh optical depths

      REAL dtrl(kz,kw)

* other:

      REAL srayl, wc, wmicrn, xx
      INTEGER iz, iw

*_______________________________________________________________________

* compute Rayleigh cross sections and depths:

      DO 10, iw = 1, nw - 1
         wc = (wl(iw) + wl(iw+1))/2.

* Rayleigh scattering cross section from WMO 1985 (originally from
* Nicolet, M., On the molecular scattering in the terrestrial atmosphere:
* An empirical formula for its calculation in the homoshpere, Planet.
* Space Sci., 32, 1467-1468, 1984.

         wmicrn =  wc/1.E3
         IF( wmicrn .LE. 0.55) THEN
            xx = 3.6772 + 0.389*wmicrn + 0.09426/wmicrn
         ELSE
            xx = 4. + 0.04
         ENDIF
         srayl = 4.02e-28/(wmicrn)**xx

* alternate (older) expression from
* Frohlich and Shaw, Appl.Opt. v.11, p.1773 (1980).
C     xx = 3.916 + 0.074*wmicrn + 0.050/wmicrn
C     srayl(iw) = 3.90e-28/(wmicrn)**xx

         DO 20, iz = 1, nz - 1
            dtrl(iz,iw) = c(iz)*srayl
   20    CONTINUE

   10 CONTINUE
*_______________________________________________________________________

      RETURN
      END


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_ALFA_N_BETA

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_SLOPE
    USE MR_DEF_ACTIVITY
    USE MR_DEF_TIMING

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_ALFA_N_BETA

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_ALFA_N_BETA( NI , NJ , NK , HYD_D3 , ALFA , BETA )

    USE MR_MOD_OPERATOR_UV
    USE MR_MOD_CALC_GRAD_XY

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (CARD_KIND) , INTENT(INOUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,1:2,1:NK) :: HYD_D3

    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,1:2) :: ALFA , BETA

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: GRAD_XY_ZS

    INTEGER(IJID_KIND) :: I , J
    INTEGER            :: DIM
    INTEGER(KKID_KIND) :: K

  ! INITIALIZE BETA
    DO DIM = 1 , 2
      !BLOCK
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            BETA( I , J ,DIM) = 0.0
          END DO
        END DO
      !END BLOCK
      DO K = 1 , NK
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            BETA( I , J ,DIM) = BETA( I , J ,DIM) + DSIGMA * HYD_D3( I , J ,DIM, K )
          END DO
        END DO
      END DO
    END DO

  ! REVISE HYD_D3
    DO DIM = 1 , 2
      DO K = 1 , NK
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            HYD_D3( I , J ,DIM, K ) = HYD_D3( I , J ,DIM, K ) - BETA( I , J ,DIM)
          END DO
        END DO
      END DO
    END DO

    BETA = BETA .MRUVMTP. H

  ! CALCULATE ALFA AND BETA WITH THE AID OF GRAD_XY_ZS
    CALL MR_CALC_GRAD_XY_SS( NI , NJ , ZSU , ZSV , GRAD_XY_ZS )

    DO J = 1 , NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        ALFA( I , J ,1) =   &
        -   DT * MW( I , J ) * H( I , J ) *   &
        &               PHI  * FUV( I , J ,1,1)
      END DO
    END DO
    DO J = 1 , NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
          BETA( I , J ,1) = BETA( I , J ,1)   &
          + DT * MW( I , J ) * H( I , J ) *   &
            ( SLOPEPAR *     FUV( I , J ,1,1) * SQRT(  GUV( I , J ,1,1)  ) * SLOPE   &   ! ADDITIONAL SLOPE TERM
            - ( (1.0-PHI) *  FUV( I , J ,1,1) * GRAD_XY_ZS( I , J ,1)   &
              +              FUV( I , J ,1,2) * GRAD_XY_ZS( I , J ,2)   &
              )   &
          & )
        END IF
      END DO
    END DO

    DO J = 1 , NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        ALFA( I , J ,2) =   &
        -   DT * MW(I , J ) * H( I , J ) *   &
        &              PHI  * FUV( I , J ,2,2)
      END DO
    END DO
    DO J = 1 , NJ
     !DIR$ VECTOR ALIGNED
      DO I = 1 , NI
        IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
          BETA( I , J ,2) = BETA( I , J ,2)   &
          + DT * MW( I , J ) * H( I , J ) *   &
            ( SLOPEPAR *     FUV( I , J ,2,1) * SQRT(  GUV( I , J ,1,1)  ) * SLOPE   &   ! ADDITIONAL SLOPE TERM
            - (              FUV( I , J ,2,1) * GRAD_XY_ZS( I , J ,1)   &
              + (1.0-PHI) *  FUV( I , J ,2,2) * GRAD_XY_ZS( I , J ,2)   &
              )   &
          & )
        END IF
      END DO
    END DO

  END SUBROUTINE MR_CALC_ALFA_N_BETA

  END MODULE MR_MOD_CALC_ALFA_N_BETA


subroutine rptt3(ixyz,icoor,imp,impt,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,bsasdq,cmbsasdq,cpbsasdq)
    ! Riemann solver in the transverse direction for the 3d Burgers' equation
    !    q_t  +  u*(.5*q^2)_x + v*(.5*q^2)_y + w*(.5*q^2)_z = 0
    ! where u,v,w are a given scalars, stored in the vector coeff
    ! that is set in setprob.f and passed in the common block comrp.
    !
    ! On input,
    !
    !    ql,qr is the data along some one-dimensional slice, as in rpn3
    !         This slice is
    !             in the x-direction if ixyz=1,
    !             in the y-direction if ixyz=2, or
    !             in the z-direction if ixyz=3.
    !
    !    bsasdq is an array of flux differences that result from a
    !         transverse splitting (a previous call to rpt3).
    !         This stands for B^* A^* \Dq but could represent any of
    !         6 possibilities, e.g.  C^* B^* \Dq, as specified by ixyz
    !         and icoor (see below).
    !         Moreover, each * represents either + or -, as specified by
    !         imp and impt.
    !
    !    ixyz indicates the direction of the original Riemann solve,
    !         called the x-like direction in the table below:
    !
    !               x-like direction   y-like direction   z-like direction
    !      ixyz=1:        x                  y                  z
    !      ixyz=2:        y                  z                  x
    !      ixyz=3:        z                  x                  y
    !
    !    icoor indicates direction in which the transverse solve should
    !         be performed.
    !      icoor=2: split in the y-like direction.
    !      icoor=3: split in the z-like direction.
    !
    !    For example,
    !        ixyz=1, icoor=3 means bsasdq=B^*A^*\Dq, and should be
    !                        split in z into
    !                           cmbsasdq = C^-B^*A^*\Dq,
    !                           cpbsasdq = C^+B^*A^*\Dq.
    !
    !        ixyz=2, icoor=3 means bsasdq=C^*B^*\Dq, and should be
    !                        split in x into
    !                           cmbsasdq = A^-C^*B^*\Dq,
    !                           cpbsasdq = A^+C^*B^*\Dq.
    !
    !    The parameters imp and impt are generally needed only if aux
    !    arrays are being used, in order to access the appropriate
    !    variable coefficients.

    implicit none

    integer, intent(in) :: ixyz, icoor, maxm, meqn, mwaves, mbc, mx, maux, imp, impt

    double precision, intent(in)  :: ql, qr, bsasdq, aux1, aux2, aux3
    double precision, intent(out) :: cmbsasdq, cpbsasdq
    dimension       ql(meqn,1-mbc:maxm+mbc)
    dimension       qr(meqn,1-mbc:maxm+mbc)
    dimension   bsasdq(meqn,1-mbc:maxm+mbc)
    dimension cmbsasdq(meqn,1-mbc:maxm+mbc)
    dimension cpbsasdq(meqn,1-mbc:maxm+mbc)
    dimension     aux1(maux,1-mbc:maxm+mbc,3)
    dimension     aux2(maux,1-mbc:maxm+mbc,3)
    dimension     aux3(maux,1-mbc:maxm+mbc,3)

    double precision :: coeff
    common /cparam/ coeff(3)

    integer :: iuvw, i
    double precision :: sc

    ! set iuvw = 1 for u, 2 for v, 3 for w component of velocity
    ! depending on transverse direction:
    iuvw = ixyz + icoor - 1
    if (iuvw.gt.3) iuvw = iuvw-3

    ! transverse wave goes up or down with speed based on data for
    ! original normal Riemann problem.

    do i=2-mbc,mx+mbc
        sc = coeff(iuvw) * 0.5d0*(qr(1,i-1) + ql(1,i))
        cmbsasdq(1,i) = dmin1(sc, 0.d0) * bsasdq(1,i)
        cpbsasdq(1,i) = dmax1(sc, 0.d0) * bsasdq(1,i)
    end do

    return
end subroutine rptt3


!=============================================================================
subroutine hilbert(mskip,nob,xob,yob,test_set)
!=============================================================================
!$$$  subprogram documentation block
!                .      .    .                                        .
! subprogram:    hilbert
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-09-22  lueken - added subprogram doc block
!
!   input argument list:
!    mskip
!    nob
!    xob,yob
!
!   output argument list:
!    test_set
!
! attributes:
!   language: f90
!   machine:
!
! notes:
! Map these data to a Hilbert curve using xy_to_hil, convert the base-4
! representation of the hilbert parameter to an ordinary real, using
! hil_to_r. Then order the obs along this space-filling curve by invoking
! the efficient sorting procedure, bsort. The resulting linked list of obs
! is accessed by "firsta" and terminated when "next(iob)" ==0.
!
! From this linked list, "A", construct linked subsets, "B", that can be used
! us validation subsets. Members of old A not able to be put into any of the
! mskip B subset are gathered into a reconstritued lined list, new "A". All
! this is done in subroutine getvalsets.
!
!$$$ end documentation block

use phil, only: xy_to_hil,hil_to_r,bsort
use phil1, only: getvalsets
use kinds, only: r_kind,i_kind

implicit none

integer(i_kind),parameter        :: ngen=15
!real(r_kind),parameter          :: delta=.001_r_kind,xhskip=.00035_r_kind
real(r_kind),parameter           :: xhskip=.00030_r_kind
!real(r_kind),parameter          :: delta=.001_r_kind,xhskip=.00025_r_kind
!real(r_kind),parameter          :: delta=.001_r_kind,xhskip=.00001_r_kind
!real(r_kind),parameter          :: delta=.001_r_kind,xhskip=.005_r_kind

integer(i_kind)                ,intent(IN   ) :: mskip,nob
real(r_kind), dimension(nob)   ,intent(IN   ) :: xob,yob

integer(i_kind), dimension(nob),intent(  OUT) :: test_set

real(r_kind),dimension(nob)     :: xh
integer(i_kind),dimension(nob)  :: next
integer(i_kind),dimension(ngen) :: hil4
integer(i_kind)                 :: iob,iskip,isamp         &
                          ,firsta,count
integer(i_kind),dimension(mskip):: firstb

do iob=1,nob
   call xy_to_hil(ngen,xob(iob),yob(iob),hil4)
   call hil_to_r(1,ngen,hil4,xh(iob))
enddo
call bsort(1,nob,xh,next,firsta)

count=0
iob=firsta
do isamp=1,nob
   if(iob==0)exit
   count=count+1
   iob=next(iob)
enddo

call getvalsets(nob, mskip,xhskip,xh,next, firsta,firstb)

test_set=0

do iskip=1,mskip
   count=0
   iob=firstb(iskip)
   do isamp=1,nob
      if(iob==0)exit
      count=count+1
      test_set(iob)=iskip
      iob=next(iob)
   enddo
enddo

count=0
iob=firsta
do isamp=1,nob
   if(iob==0)exit
   count=count+1
   iob=next(iob)
enddo

end subroutine hilbert