c        routines for determining length of multipole and
c         local expansions based on size of box in wavelengths
c
c-----------------------------------------------------------------------------
c
c      h3dterms - determine number of terms in mpole expansions for box
c           of size "size" with Helmholtz parameter zk.
c
c      h3dterms_list2 - build the number of terms table for all boxes
c           in list 2
c
c-----------------------------------------------------------------------------
c
c
c
      subroutine h3dterms(size, zk, eps, nterms)
      implicit real *8 (a-h,o-z)
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     Maximum number of terms is 1000, which
c     works for boxes up to 160 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      complex *16  zk, z1, z2, z3, jfun(0:5000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:5000), fhder(0:1)
c
c
      z1 = (zk*size)*1.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
c
      ntmax = 5000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*size) .lt. 1.0d0) rscale = cdabs(zk*size)
      call h3dall(ntmax,z1,rscale,hfun,ifder,fhder)
      z2 = (zk*size) * dsqrt(3d0)/2.0d0

      call besseljs3d(ntmax, z2, rscale, jfun, ifder, fjder)
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
c
      enddo
c
c       ... computational box is too big, set nterms to 1000
c
        nterms=5000
c
      return
      end
c
c
c
c
c
      subroutine h3dterms_far(size, zk, eps, nterms)
      implicit real *8 (a-h,o-z)
c
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     This routine assumes slightly larger separation of boxes: the
c     first unit box is located at the origin and the second box is
c     located at (3,0,0).
c
c     Maximum number of terms is 1000, which
c     works for boxes up to 160 wavelengths in size
c
c
c-----------------------------------------------------------------------------
c
      complex *16  zk, z1, z2, z3, jfun(0:2000), ht0,
     1             ht1, ht2, fjder(0:1), ztmp,
     1             hfun(0:2000), fhder(0:1)
c
      z1 = (zk*size)*2.5d0
c
c       the code will run out memory if frequency is too small
c       set frequency to something more reasonable, nterms is
c       approximately the same for all small frequencies
c
ccc        if( abs(z1) .lt. 1d-6 ) z1=1d-6
c
      ntmax = 1000
      ifder = 0
      rscale = 1.0d0
      if (cdabs(zk*size) .lt. 1.0d0) rscale = cdabs(zk*size)
      call h3dall(ntmax,z1,rscale,hfun,ifder,fhder)
      z2 = (zk*size) * dsqrt(3d0)/2.d0
c
      ier1 = 0
c
      call besseljs3d(ntmax, z2, rscale, jfun, ifder, fjder)
c
      xtemp1 = cdabs(jfun(0)*hfun(0))
      xtemp2 = cdabs(jfun(1)*hfun(1))
      xtemp0 = xtemp1+xtemp2
      nterms = 1
      do j = 2, ntmax
        xtemp1 = cdabs(jfun(j)*hfun(j))
        xtemp2 = cdabs(jfun(j-1)*hfun(j-1))
        xtemp = xtemp1+xtemp2
        if(xtemp .lt. eps*xtemp0)then
          nterms = j + 1
          return
        endif
      enddo
c
c       ... computational box is too big, set nterms to 1000
c
        nterms=1000
c
      return
      end
c
c
c
c


use LinearSolverClass
use TimeClass
use RandomClass
use MPIClass
implicit none

integer(int32),parameter :: n=1000000

logical,parameter :: CRS=.false.

type(LinearSolver_) :: solver
type(Time_) :: time
type(MPI_) :: mpid
type(Random_) :: random
real(real64) :: mm(n),x(n)
integer(int32) :: i, j, itr,m

call mpid%start()

m = n + (n-1)*2
solver%val = zeros(m)
solver%Index_I = int(zeros(m))
solver%Index_J = int(zeros(m))
solver%b = zeros(n)
solver%b_Index_J = int(zeros(n))
itr = 0
do i=1,n
    ! COO matrix

    if(i==1)then
        itr = itr+1
        solver%val(itr) = 1.0d0
        solver%Index_I(itr) = i
        solver%Index_J(itr) = i
        itr = itr+1
        solver%val(itr) = 0.50d0
        solver%Index_I(itr) = i
        solver%Index_J(itr) = i+1
    endif

    if(2<=i .and. i <=n-1)then
        itr = itr+1
        solver%val(itr) = 0.50d0
        solver%Index_I(itr) = i
        solver%Index_J(itr) = i-1
        itr = itr+1
        solver%val(itr) = 0.50d0
        solver%Index_I(itr) = i
        solver%Index_J(itr) = i
        itr = itr+1
        solver%val(itr) = 0.50d0
        solver%Index_I(itr) = i
        solver%Index_J(itr) = i+1
        if(i==n-1)then
            solver%val(itr) = 0.00d0
        endif
    endif

    if(i==n)then
        itr = itr+1
        solver%val(itr) = 1.00d0
        solver%Index_I(itr) = i
        solver%Index_J(itr) = i
        itr = itr+1
        solver%val(itr) = 0.00d0
        solver%Index_I(itr) = i
        solver%Index_J(itr) = i-1
    endif

    !RHS
    solver%b_Index_J(i) = i
enddo

solver%b(n-1) = -5.0d0
solver%b(n) = 10.0d0
! matmul operation
!call time%start()
!mm = matmul(Amat,solver%b)
!call time%show()
!print *, norm(mm)

! matmul operation
!print *, solver%val
!print *, solver%Index_I
!print *, solver%Index_J
!print *, solver%b

solver%x = zeros(size(solver%b) )

!print *, solver%val
!print *, solver%Index_I
!print *, solver%Index_J
!print *, solver%b
!stop
! matmul operation
solver%itrmax = 10000
solver%er0 = dble(1.0e-12)

if(CRS)then
    !>>>>>>> CRS format
    solver%x=0.0d0
    call time%start()
    call solver%convertCOOtoCRS(OpenMP=false)
    call time%show()
    call bicgstab_CRS(solver%val, solver%CRS_index_I, solver%index_J, &
        solver%x, solver%b, solver%itrmax, solver%er0)
    call time%show()
    print *,"CRS", norm(solver%x)
else
    !>>>>>>> COO format
    solver%x=0.0d0
    call time%start()
    call bicgstab_COO(solver%val, solver%index_I, solver%index_J, &
        solver%x, solver%b, solver%itrmax, solver%er0)
    call time%show()
    print *,"COO", norm(solver%x)
endif

call mpid%end()

end


module points_in_poly_mod
    !
    !! Module to find whether points are inside (or on the boundary of) a polygon
    !
    !! The tests suggest being on the boundary is counted as being inside, although
    !! I would not rely on that behaviour always being true for complex polygons.
    !!
    !! Main routine is
    !!   points_in_poly(vertx, verty, px, py, is_inside)
    !! where all arguments are arrays
    !! (with size(vertx) == size(verty) & (size(px) == size(py) == size(is_inside))
    !!
    !! A discussion of the problem is here (we use a similar algorithm)
    !! https://www.ecse.rpi.edu/~wrf/Research/Short_Notes/pnpoly.html
    !
    use global_mod, only: ip, dp
    implicit none

    contains

    ! Find if a single point (px, py) is inside a poly defined by nvert vertices
    ! (vertx, verty).
    !
    ! @param nvert number of vertices in the polygon
    ! @param vertx x coordinates of polygon vertices, in order
    ! @param verty y coordinates of polygon vertices in order
    ! @param px x coordinates of points which might be in or outside the polygon
    ! @param py y coordinates of points which might be in or outside the polygon
    ! @param is_inside output logical array which indicates if each px,py is inside the polygon
    !
    pure subroutine point_in_poly(nvert, vertx, verty, px, py, is_inside)
        integer(ip), intent(in):: nvert
        real(dp), intent(in):: vertx(nvert), verty(nvert), px, py
        logical, intent(out):: is_inside

        integer(ip) :: i, j
        real(dp) :: g0

        is_inside = .FALSE.

        do i = 1, nvert
            ! j is an index of the next vertex
            if(i == 1) then
                j = nvert
            else
                j = i - 1
            end if

            ! Main test
            if((verty(i) > py) .neqv. (verty(j) > py)) then
                g0 = (vertx(j) - vertx(i)) * (py - verty(i)) / (verty(j) - verty(i)) + vertx(i)
                if(px < g0) then
                    is_inside = (.NOT. is_inside)
                end if
            end if

        end do
    end subroutine

    ! Generalise point_in_poly to many points
    !
    ! Use a bounding box check which could speed up some cases.
    !
    ! @param vertx x coordinates of polygon vertices, in order
    ! @param verty y coordinates of polygon vertices in order
    ! @param px x coordinates of points which might be in or outside the polygon
    ! @param py y coordinates of points which might be in or outside the polygon
    ! @param is_inside output logical array which indicates if each px,py is inside the polygon
    !
    pure subroutine points_in_poly(vertx, verty, px, py, is_inside)
        real(dp), intent(in):: vertx(:), verty(:), px(:), py(:)
        logical, intent(out):: is_inside(:)

        integer(ip):: i, nvert, np

        ! bounding box for polygon to speed up check
        real(dp):: min_vertx, max_vertx, min_verty, max_verty

        nvert = size(vertx, kind=ip)
        np = size(px, kind=ip)

        min_vertx = minval(vertx)
        max_vertx = maxval(vertx)
        min_verty = minval(verty)
        max_verty = maxval(verty)

        do i = 1, np
            if(px(i) >= min_vertx .and. px(i) <= max_vertx .and. &
               py(i) >= min_verty .and. py(i) <= max_verty) then
                call point_in_poly(nvert, vertx, verty, px(i), py(i), is_inside(i))
            else
                is_inside(i) = .FALSE.
            end if
        end do

    end subroutine

    ! Test. Call as test_points_in_poly_mod()
    !
    subroutine test_points_in_poly_mod
        integer(ip):: nvert

        ! doesn't seem to matter whether last point == first point or not
        real(dp), dimension(5) :: vertx = [0._dp, 0.0_dp, 1.0_dp, 1.0_dp, 0._dp]
        real(dp), dimension(5) :: verty = [0._dp, 1.0_dp, 1.0_dp, 0.0_dp, 0._dp]
        !real(dp), dimension(4) :: vertx = [0._dp, 0.0_dp, 1.0_dp, 1.0_dp]
        !real(dp), dimension(4) :: verty = [0._dp, 1.0_dp, 1.0_dp, 0.0_dp]

        integer(ip):: i
        logical:: is_inside_result

        type test_point_type
            real(dp):: p(2)
            logical:: is_inside
        end type

        type(test_point_type):: test_points(10)

        real(dp):: test_points_array(10, 2)
        logical:: is_inside_result_array(10), is_inside_array(10)

        nvert = size(vertx, kind=ip)

        ! Manually make test points and flag if they lie on a boundary
        !
        ! It seems the routine counts being 'on' the boundary as being inside
        ! (although that may vary in more complex cases due to round-off?)
        !
        test_points(1) = test_point_type([-1.0_dp, 0.0_dp], .FALSE.)
        test_points(2) = test_point_type([-1.0_dp, 0.5_dp], .FALSE.)
        test_points(3) = test_point_type([ 0.0_dp, 0.0_dp], .TRUE.)
        test_points(4) = test_point_type([ 0.0_dp, 0.5_dp], .TRUE.)
        test_points(5) = test_point_type([ 0.5_dp, 0.5_dp], .TRUE.)
        test_points(6) = test_point_type([ 0.1_dp, 0.9_dp], .TRUE.)
        test_points(7) = test_point_type([ 0.1_dp, 2.9_dp], .FALSE.)
        test_points(8) = test_point_type([ 0.1_dp, 0.0_dp], .TRUE.)
        test_points(9) = test_point_type([ 1.0e-10_dp, 1.0e-10_dp], .TRUE.)
        test_points(10) = test_point_type([ -1.0e-10_dp, -1.0e-10_dp], .FALSE.)

        do i = 1, 10

            call point_in_poly(size(vertx)*1_ip, vertx, verty, &
                test_points(i)%p(1), test_points(i)%p(2), is_inside_result)

            if(is_inside_result .eqv. test_points(i)%is_inside) then
                print*, 'PASS'
            else
                print*, 'FAIL on point ', i, ' : ', test_points(i)
            end if

        end do

        ! Test the array version
        do i = 1, 10
            test_points_array(i,:) = test_points(i)%p
            is_inside_array(i) = test_points(i)%is_inside
        end do

        call points_in_poly(vertx, verty, test_points_array(:,1), &
            test_points_array(:,2), is_inside_result_array)

        if(all(is_inside_result_array .eqv. is_inside_array)) then
            print*, 'PASS'
        else
            print*, 'FAIL on array test'
        end if

    end subroutine

end module


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program test_random

! test the uniform random number generator routine

use      types_mod, only : r8
use  utilities_mod, only : register_module, &
                           open_file, close_file, &
                           initialize_utilities, finalize_utilities, &
                           squeeze_out_blanks
use random_seq_mod, only : random_seq_type, init_random_seq, random_uniform

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

type (random_seq_type) :: r
integer :: i, j, n, f
real(r8) :: r1, sum
real(r8) :: mean, compmean, compdiffm
logical  :: write_this_one
character(len=50) :: formf = '(I12,4(F16.5))'
character(len=256) :: fname, temp

logical :: write_me = .true.       ! if true, write each distribution into a file for later diagnostics
integer :: write_limit = 1000000   ! but only if rep count is not greater than this limit

type t_inputs
 integer  :: t_nreps
end type

! to add more tests or change the parameters, specify a test count
! and update the sets of inputs here:

integer, parameter :: ntests = 11
type(t_inputs) :: t(ntests) = (/ &
    t_inputs(       100), &
    t_inputs(       500), &
    t_inputs(      1000), &
    t_inputs(      5000), &
    t_inputs(     10000), &
    t_inputs(     50000), &
    t_inputs(    100000), &
    t_inputs(    500000), &
    t_inputs(   1000000), &
    t_inputs(   5000000), &
    t_inputs(  10000000) /)

call initialize_utilities('test_random')
call register_module(source,revision,revdate)

write(*, *) ''
write(*, *) 'sample size   computed mean     actual mean       diff mean     % diff mean'
write(*, *) ''

do j=1, ntests

   call init_random_seq(r, 5)

   n = t(j)%t_nreps

   ! save all values in a file for post-plotting?
   write_this_one = (write_me .and. n <= write_limit)

   if (write_this_one) then
      write(temp, "(A,I10)") "random_", n
      call squeeze_out_blanks(temp, fname)
      f = open_file(fname)
   endif

   ! analytical values:
   mean = 0.5

   sum = 0.0_r8

   do i = 1, n
      r1 = random_uniform(r)

      if (write_this_one) write(f,*) r1

      sum = sum + r1
   end do

   if (write_this_one) call close_file(f)

   ! computed values:
   compmean = sum / n

   ! differences
   compdiffm  = compmean - mean

   write(*, formf) n, mean, compmean, compdiffm, &
                   abs(compdiffm/mean) * 100._r8

enddo

call finalize_utilities()

end program test_random

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!*==zlargv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZLARGV generates a vector of plane rotations with real cosines and complex sines.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZLARGV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC )
!
!       .. Scalar Arguments ..
!       INTEGER            INCC, INCX, INCY, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   C( * )
!       COMPLEX*16         X( * ), Y( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLARGV generates a vector of complex plane rotations with real
!> cosines, determined by elements of the complex vectors x and y.
!> For i = 1,2,...,n
!>
!>    (        c(i)   s(i) ) ( x(i) ) = ( r(i) )
!>    ( -conjg(s(i))  c(i) ) ( y(i) ) = (   0  )
!>
!>    where c(i)**2 + ABS(s(i))**2 = 1
!>
!> The following conventions are used (these are the same as in ZLARTG,
!> but differ from the BLAS1 routine ZROTG):
!>    If y(i)=0, then c(i)=1 and s(i)=0.
!>    If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of plane rotations to be generated.
!> \endverbatim
!>
!> \param[in,out] X
!> \verbatim
!>          X is COMPLEX*16 array, dimension (1+(N-1)*INCX)
!>          On entry, the vector x.
!>          On exit, x(i) is overwritten by r(i), for i = 1,...,n.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>          The increment between elements of X. INCX > 0.
!> \endverbatim
!>
!> \param[in,out] Y
!> \verbatim
!>          Y is COMPLEX*16 array, dimension (1+(N-1)*INCY)
!>          On entry, the vector y.
!>          On exit, the sines of the plane rotations.
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>          The increment between elements of Y. INCY > 0.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!> \endverbatim
!>
!> \param[in] INCC
!> \verbatim
!>          INCC is INTEGER
!>          The increment between elements of C. INCC > 0.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel
!>
!>  This version has a few statements commented out for thread safety
!>  (machine parameters are computed on each entry). 10 feb 03, SJH.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZLARGV(N,X,Incx,Y,Incy,C,Incc)
      IMPLICIT NONE
!*--ZLARGV126
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Incc , Incx , Incy , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION C(*)
      COMPLEX*16 X(*) , Y(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION TWO , ONE , ZERO
      PARAMETER (TWO=2.0D+0,ONE=1.0D+0,ZERO=0.0D+0)
      COMPLEX*16 CZERO
      PARAMETER (CZERO=(0.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
!     LOGICAL            FIRST

      INTEGER count , i , ic , ix , iy , j
      DOUBLE PRECISION cs , d , di , dr , eps , f2 , f2s , g2 , g2s ,   &
     &                 safmin , safmn2 , safmx2 , scale
      COMPLEX*16 f , ff , fs , g , gs , r , sn
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH , DLAPY2
      EXTERNAL DLAMCH , DLAPY2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , DCMPLX , DCONJG , DIMAG , INT , LOG , MAX ,&
     &          SQRT
!     ..
!     .. Statement Functions ..
      DOUBLE PRECISION ABS1 , ABSSQ
!     ..
!     .. Save statement ..
!     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
!     ..
!     .. Data statements ..
!     DATA               FIRST / .TRUE. /
!     ..
!     .. Statement Function definitions ..
      ABS1(ff) = MAX(ABS(DBLE(ff)),ABS(DIMAG(ff)))
      ABSSQ(ff) = DBLE(ff)**2 + DIMAG(ff)**2
!     ..
!     .. Executable Statements ..
!
!     IF( FIRST ) THEN
!        FIRST = .FALSE.
      safmin = DLAMCH('S')
      eps = DLAMCH('E')
      safmn2 = DLAMCH('B')**INT(LOG(safmin/eps)/LOG(DLAMCH('B'))/TWO)
      safmx2 = ONE/safmn2
!     END IF
      ix = 1
      iy = 1
      ic = 1
      DO i = 1 , N
         f = X(ix)
         g = Y(iy)
!
!        Use identical algorithm as in ZLARTG
!
         scale = MAX(ABS1(f),ABS1(g))
         fs = f
         gs = g
         count = 0
         IF ( scale>=safmx2 ) THEN
            DO
               count = count + 1
               fs = fs*safmn2
               gs = gs*safmn2
               scale = scale*safmn2
               IF ( scale<safmx2 .OR. count>=20 ) EXIT
            ENDDO
         ELSEIF ( scale<=safmn2 ) THEN
            IF ( g==CZERO ) THEN
               cs = ONE
               sn = CZERO
               r = f
               GOTO 50
            ENDIF
            DO
               count = count - 1
               fs = fs*safmx2
               gs = gs*safmx2
               scale = scale*safmx2
               IF ( scale>safmn2 ) EXIT
            ENDDO
         ENDIF
         f2 = ABSSQ(fs)
         g2 = ABSSQ(gs)
         IF ( f2<=MAX(g2,ONE)*safmin ) THEN
!
!           This is a rare case: F is very small.
!
            IF ( f==CZERO ) THEN
               cs = ZERO
               r = DLAPY2(DBLE(g),DIMAG(g))
!              Do complex/real division explicitly with two real
!              divisions
               d = DLAPY2(DBLE(gs),DIMAG(gs))
               sn = DCMPLX(DBLE(gs)/d,-DIMAG(gs)/d)
               GOTO 50
            ENDIF
            f2s = DLAPY2(DBLE(fs),DIMAG(fs))
!           G2 and G2S are accurate
!           G2 is at least SAFMIN, and G2S is at least SAFMN2
            g2s = SQRT(g2)
!           Error in CS from underflow in F2S is at most
!           UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
!           If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
!           and so CS .lt. sqrt(SAFMIN)
!           If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
!           and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
!           Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
            cs = f2s/g2s
!           Make sure abs(FF) = 1
!           Do complex/real division explicitly with 2 real divisions
            IF ( ABS1(f)>ONE ) THEN
               d = DLAPY2(DBLE(f),DIMAG(f))
               ff = DCMPLX(DBLE(f)/d,DIMAG(f)/d)
            ELSE
               dr = safmx2*DBLE(f)
               di = safmx2*DIMAG(f)
               d = DLAPY2(dr,di)
               ff = DCMPLX(dr/d,di/d)
            ENDIF
            sn = ff*DCMPLX(DBLE(gs)/g2s,-DIMAG(gs)/g2s)
            r = cs*f + sn*g
         ELSE
!
!           This is the most common case.
!           Neither F2 nor F2/G2 are less than SAFMIN
!           F2S cannot overflow, and it is accurate
!
            f2s = SQRT(ONE+g2/f2)
!           Do the F2S(real)*FS(complex) multiply with two real
!           multiplies
            r = DCMPLX(f2s*DBLE(fs),f2s*DIMAG(fs))
            cs = ONE/f2s
            d = f2 + g2
!           Do complex/real division explicitly with two real divisions
            sn = DCMPLX(DBLE(r)/d,DIMAG(r)/d)
            sn = sn*DCONJG(gs)
            IF ( count/=0 ) THEN
               IF ( count>0 ) THEN
                  DO j = 1 , count
                     r = r*safmx2
                  ENDDO
               ELSE
                  DO j = 1 , -count
                     r = r*safmn2
                  ENDDO
               ENDIF
            ENDIF
         ENDIF
 50      C(ic) = cs
         Y(iy) = sn
         X(ix) = r
         ic = ic + Incc
         iy = iy + Incy
         ix = ix + Incx
      ENDDO
!
!     End of ZLARGV
!
      END SUBROUTINE ZLARGV


************************************************************************
*
*     Function LOGLK                                  Called by: CALIBR
*
*     calculate the log likelihood of Tobit regression (Paarsch, 1984)
*
*     locals vars
*     -----------
*     YHAT    predicted value of the response variable
*
************************************************************************
      DOUBLE PRECISION FUNCTION LOGLK(NPAR,NOBSC,XLCAL,YLCAL,CENSFLAG,
     &                                PARAML,RESSTD,NOBSCI)
*
*     subroutine arguments
*
      INTEGER*4 NPAR,NOBSC,NOBSCI
      LOGICAL CENSFLAG(*)
      DOUBLE PRECISION RESSTD,YLCAL(*),PARAML(*),XLCAL(NOBSCI,*)
*
*     local vars
*
      INTEGER*4 I
      DOUBLE PRECISION YHAT
*
*     function declarations
*
      DOUBLE PRECISION ERF,PRED
*
*     compute the log likelihood due to censored and uncensored data
*
*     if the observation is censored, its contribution to LOGLK is based
*     on the integral of the probability density of a standardized
*     normal variable from X to infinity (the complement of the
*     cumulative distribution function)(Abramowitz and Stegun, 1964, p.
*     297 & 931). If the observation is uncensored, the contribution is
*     based on the probability density function of the standard normal
*     distribution, divided by the residual standard deviation (RESSTD).
*
      LOGLK = 0.D0

      DO 10 I=1,NOBSC
         YHAT = PRED(NPAR,NOBSCI,I,XLCAL,PARAML)
         IF (CENSFLAG(I)) THEN
            LOGLK = LOGLK
     &             + DLOG((1.D0
     &                -ERF((-(YLCAL(I)-YHAT)/RESSTD)/DSQRT(2.D0)))/2.D0)
         ELSE
            LOGLK = LOGLK
     &             + DLOG(((1.D0/DSQRT(2.D0*3.14159265359D0)) *
     &                     DEXP(-(((YLCAL(I)-YHAT)/RESSTD)**2)/2.D0)
     &                                                     /RESSTD))
         ENDIF
 10   CONTINUE

      RETURN
      END


! =====================================================
subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =====================================================

! HLLE solver for the 2D shallow water equations.

! waves: 2
! equations: 3

! Conserved quantities:
!       1 depth
!       2 x-momentum
!       3 y-momentum

    implicit none

    integer, intent(in) :: ixy, maxm, meqn, mwaves, maux, mbc, mx
    double precision, dimension(meqn,1-mbc:maxm+mbc), intent(in) :: ql, qr
    double precision, dimension(maux,1-mbc:maxm+mbc), intent(in) :: auxl, auxr
    double precision, dimension(meqn, mwaves, 1-mbc:maxm+mbc), intent(out) :: wave
    double precision, dimension(mwaves, 1-mbc:maxm+mbc), intent(out) :: s
    double precision, dimension(meqn, 1-mbc:maxm+mbc), intent(out) :: amdq, apdq

    double precision :: u_l, u_r, c_l, c_r, u_hat, c_hat, v_l, v_r, v_hat, h_hat
    double precision :: h_l, h_r, hsqrt_l, hsqrt_r, hsq2
    double precision :: grav
    double precision :: h_m, hu_m, hv_m, s1, s2
    integer :: depth, mu, mv
    integer :: i, m, mw

    common /cparam/  grav

!     # set mu to point to  the component of the system that corresponds
!     # to momentum in the direction of this slice, mv to the orthogonal
!     # momentum:
!

    depth = 1
    if (ixy.eq.1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

    do i=2-mbc,mx+mbc
        h_l = qr(depth,i-1)
        h_r = ql(depth,i)
        ! Velocity
        u_l = qr(mu,i-1) / qr(depth,i-1)
        u_r = ql(mu,i  ) / ql(depth,i  )
        v_l = qr(mv,i-1) / qr(depth,i-1)
        v_r = ql(mv,i  ) / ql(depth,i  )
        ! Sound speed
        c_l = dsqrt(grav*h_l)
        c_r = dsqrt(grav*h_r)

        hsqrt_l = dsqrt(qr(depth,i-1))
        hsqrt_r = dsqrt(ql(depth,i))
        hsq2 = hsqrt_l + hsqrt_r
        h_hat = 0.5*(h_l + h_r)
        u_hat = (u_l*hsqrt_l + u_r*hsqrt_r) / hsq2
        v_hat = (v_l*hsqrt_l + v_r*hsqrt_r) / hsq2
        c_hat = dsqrt(grav*h_hat)

        ! Speeds of non-shear waves
        s1 = min(u_l - c_l, u_hat - c_hat)
        s2 = max(u_r + c_r, u_hat + c_hat)

        ! middle" state
        h_m = (ql(mu,i) - qr(mu,i-1) - s2*ql(depth,i) + s1*qr(depth,i-1))/(s1-s2)
        hu_m = (ql(mu,i)*(u_r-s2) - qr(mu,i-1)*(u_l-s1) + 0.5*grav*(h_r**2 - h_l**2) ) / (s1-s2)
        hv_m = (ql(mv,i)*u_r - qr(mv,i-1)*u_l - s2*ql(mv,i) + s1*qr(mv,i-1))/(s1-s2)

        wave(depth,1,i) = h_m - h_l
        wave(mu,1,i) = hu_m - qr(mu,i-1)
        wave(mv,1,i) = hv_m - qr(mv,i-1)
        s(1,i) = s1

        wave(depth,2,i) = h_r - h_m
        wave(mu,2,i) = ql(mu,i) - hu_m
        wave(mv,2,i) = ql(mv,i) - hv_m
        s(2,i) = s2
    end do

    do m=1, meqn
        do i=2-mbc, mx+mbc
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do mw=1, mwaves
                if (s(mw,i) .lt. 0.d0) then
                    amdq(m,i) = amdq(m,i) + s(mw,i)*wave(m,mw,i)
                 else
                   apdq(m,i) = apdq(m,i) + s(mw,i)*wave(m,mw,i)
                 endif
            end do
        end do
    end do

end subroutine rpn2


MODULE AttenMod

  ! Attenuation module
  ! Routines to convert a sound speed and attenuation in user units to a complex sound speed
  ! Includes a formula for volume attenuation

  IMPLICIT NONE
  INTEGER, PARAMETER               :: MaxBioLayers = 200
  INTEGER                          :: iBio, NBioLayers
  REAL    (KIND=8) :: T = 20, Salinity = 35, pH = 8, z_bar = 0, FG   ! Francois-Garrison volume attenuation; temperature, salinity, ...

  TYPE bioStructure
     REAL (KIND=8) :: Z1, Z2, f0, Q, a0
  END TYPE bioStructure

  TYPE( bioStructure ) :: bio( MaxBioLayers )

CONTAINS
  FUNCTION CRCI( z, c, alpha, freq, freq0, AttenUnit, beta, fT )

    ! Converts real wave speed and attenuation to a single
    !  complex wave speed (with positive imaginary part)

    ! AttenUnit
    ! 6 Cases:    N Nepers/meter
    !             M dB/meter      (M for Meters)
    !             m dB/meter with a power law
    !             F dB/m-kHz      (F for Frequency dependent)
    !             W dB/wavelength (W for Wavelength)
    !             Q Q
    !             L Loss parameter
    !
    ! second letter adds volume attenuation according to standard laws:
    !             T for Thorp
    !             F for Francois Garrison
    !             B for biological
    !
    ! freq is the current frequency
    ! freq0 is the reference frequency for which the dB/meter was specified (used only for 'm')

    ! Returns
    ! c     real      part of sound speed
    ! alpha imaginary part of sound speed

    USE MathConstants

    REAL     (KIND=8), INTENT( IN )  :: freq, freq0, alpha, c, z, beta, fT
    CHARACTER (LEN=2), INTENT( IN )  :: AttenUnit
    REAL     (KIND=8)                :: f2, omega, alphaT, Thorp, a, FG
    COMPLEX  (KIND=8)                :: CRCI

    omega = 2.0 * pi * freq

    !  Convert to Nepers/m
    alphaT = 0.0
    SELECT CASE ( AttenUnit( 1 : 1 ) )
    CASE ( 'N' )
       alphaT = alpha
    CASE ( 'M' )   ! dB/m
       alphaT = alpha / 8.6858896D0
    CASE ( 'm' )   ! dB/m with power law
       alphaT = alpha / 8.6858896D0
       IF ( freq < fT ) THEN   ! frequency raised to the power beta
          alphaT = alphaT * ( freq / freq0 ) ** beta
       ELSE                    ! linear in frequency
          alphaT = alphaT * ( freq / freq0 ) * ( fT / freq0 ) ** ( beta - 1 )
       END IF
    CASE ( 'F' )   ! dB/(m kHz)
       alphaT = alpha * freq / 8685.8896D0
    CASE ( 'W' )   ! dB/wavelength
       IF ( c /= 0.0         ) alphaT = alpha * freq / ( 8.6858896D0 * c )
       !        The following lines give f^1.25 Frequency dependence
       !        FAC = SQRT( SQRT( freq / 50.0 ) )
       !        IF ( c /= 0.0 ) alphaT = FAC * alpha * freq / ( 8.6858896D0 * c )
    CASE ( 'Q' )   ! Quality factor
       IF ( c * alpha /= 0.0 ) alphaT = omega / ( 2.0 * c * alpha )
    CASE ( 'L' )   ! loss parameter
       IF ( c /= 0.0         ) alphaT = alpha * omega / c
    END SELECT

    ! added volume attenuation
    SELECT CASE ( AttenUnit( 2 : 2 ) )
    CASE ( 'T' )
       f2 = ( freq / 1000.0 ) ** 2

       ! Original formula from Thorp 1967
       ! Thorp = 40.0 * f2 / ( 4100.0 + f2 ) + 0.1 * f2 / ( 1.0 + f2 )   ! dB/kyard
       ! Thorp = Thorp / 914.4D0                 ! dB / m
       ! Thorp = Thorp / 8.6858896D0             ! Nepers / m

       ! Updated formula from JKPS Eq. 1.34
       Thorp = 3.3d-3 + 0.11 * f2 / ( 1.0 + f2 ) + 44.0 * f2 / ( 4100.0 + f2 ) + 3d-4 * f2   ! dB/km
       Thorp = Thorp / 8685.8896 ! Nepers / m

       alphaT = alphaT + Thorp
    CASE ( 'F' )   ! Francois-Garrison
       FG     = Franc_Garr( freq / 1000 );   ! dB/km
       FG     = FG / 8685.8896;                           ! Nepers / m
       alphaT = alphaT + FG
    CASE ( 'B' )   ! biological attenuation per Orest Diachok
       DO iBio = 1, NBioLayers
          IF ( z >= bio( iBio )%Z1 .AND. z <= bio( iBio )%Z2 ) THEN
             a = bio( iBio )%a0 / ( ( 1.0 - bio( iBio )%f0 ** 2 / freq ** 2  ) ** 2 + 1.0 / bio( iBio )%Q ** 2 )   ! dB/km
             a = a / 8685.8896   ! Nepers / m
             alphaT = alphaT + a
          END IF
       END DO
    END SELECT

    ! Convert Nepers/m to equivalent imaginary sound speed
    alphaT = alphaT * c * c / omega
    CRCI   = CMPLX( c, alphaT, KIND=8 )

    RETURN
  END FUNCTION CRCI

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

  FUNCTION Franc_Garr( f )

    ! Francois Garrison formulas for attenuation
    ! Based on a Matlab version by D. Jackson APL-UW

    ! mbp Feb. 2019
    ! Verified using F-G Table IV

    ! alpha = attenuation   (dB/km)
    ! f     = frequency     (kHz)
    ! T     = temperature   (deg C)
    ! S     = salinity      (psu)
    ! pH    = 7 for neutral water
    ! z_bar = depth         (m)

    !     Returns
    !        alpha = volume attenuation in dB/km

    REAL (KIND=8) :: f, Franc_Garr
    REAL (KIND=8) :: c, A1, A2, A3, P1, P2, P3, f1, f2

    c = 1412 + 3.21 * T + 1.19 * Salinity + 0.0167 * z_bar

    ! Boric acid contribution
    A1 = 8.86 / c * 10 ** ( 0.78 * pH - 5 )
    P1 = 1
    f1 = 2.8 * sqrt( Salinity / 35 ) * 10 ** ( 4 - 1245 / ( T + 273 ) )

    ! Magnesium sulfate contribution
    A2 = 21.44 * Salinity / c * ( 1 + 0.025 * T )
    P2 = 1 - 1.37D-4 * z_bar + 6.2D-9 * z_bar ** 2
    f2 = 8.17 * 10 ** ( 8 - 1990 / ( T + 273 ) ) / ( 1 + 0.0018 * ( Salinity - 35 ) )

    ! Viscosity
    P3 = 1 - 3.83D-5 * z_bar + 4.9D-10 * z_bar ** 2
    if ( T < 20 ) THEN
       A3 = 4.937D-4 - 2.59D-5 * T + 9.11D-7 * T ** 2 - 1.5D-8  * T ** 3
    else
       A3 = 3.964D-4 -1.146D-5 * T + 1.45D-7 * T ** 2 - 6.5D-10 * T ** 3
    end if

    Franc_Garr = A1 * P1 * ( f1 * f ** 2 ) / ( f1 ** 2 + f ** 2 ) + A2 * P2 * ( f2 * f ** 2 ) / ( f2 ** 2 + f ** 2 ) + &
         A3 * P3 * f ** 2

  END FUNCTION Franc_Garr

END MODULE AttenMod


*DECK CPOIR
      SUBROUTINE CPOIR (A, LDA, N, V, ITASK, IND, WORK)
C***BEGIN PROLOGUE  CPOIR
C***PURPOSE  Solve a positive definite Hermitian system of linear
C            equations.  Iterative refinement is used to obtain an
C            error estimate.
C***LIBRARY   SLATEC
C***CATEGORY  D2D1B
C***TYPE      COMPLEX (SPOIR-S, CPOIR-C)
C***KEYWORDS  HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C    Subroutine CPOIR solves a complex positive definite Hermitian
C    NxN system of single precision linear equations using LINPACK
C    subroutines CPOFA and CPOSL.  One pass of iterative refine-
C    ment is used only to obtain an estimate of the accuracy.  That
C    is, if A is an NxN complex positive definite Hermitian matrix
C    and if X and B are complex N-vectors, then CPOIR solves the
C    equation
C
C                          A*X=B.
C
C    Care should be taken not to use CPOIR with a non-Hermitian
C    matrix.
C
C    The matrix A is first factored into upper and lower
C    triangular matrices R and R-TRANSPOSE.  These
C    factors are used to calculate the solution, X.
C    Then the residual vector is found and used
C    to calculate an estimate of the relative error, IND.
C    IND estimates the accuracy of the solution only when the
C    input matrix and the right hand side are represented
C    exactly in the computer and does not take into account
C    any errors in the input data.
C
C    If the equation A*X=B is to be solved for more than one vector
C    B, the factoring of A does not need to be performed again and
C    the option to only solve (ITASK .GT. 1) will be faster for
C    the succeeding solutions.  In this case, the contents of A,
C    LDA, N, and WORK must not have been altered by the user
C    following factorization (ITASK=1).  IND will not be changed
C    by CPOIR in this case.
C
C  Argument Description ***
C    A       COMPLEX(LDA,N)
C             the doubly subscripted array with dimension (LDA,N)
C             which contains the coefficient matrix.  Only the
C             upper triangle, including the diagonal, of the
C             coefficient matrix need be entered.  A is not
C             altered by the routine.
C    LDA    INTEGER
C             the leading dimension of the array A.  LDA must be great-
C             er than or equal to N.  (terminal error message IND=-1)
C    N      INTEGER
C             the order of the matrix A.  N must be greater than
C             or equal to one.  (terminal error message IND=-2)
C    V      COMPLEX(N)
C             on entry, the singly subscripted array(vector) of di-
C               mension N which contains the right hand side B of a
C               system of simultaneous linear equations A*X=B.
C             on return, V contains the solution vector, X .
C    ITASK  INTEGER
C             if ITASK = 1, the matrix A is factored and then the
C               linear equation is solved.
C             if ITASK .GT. 1, the equation is solved using the existing
C               factored matrix A (stored in WORK).
C             if ITASK .LT. 1, then terminal terminal error IND=-3 is
C               printed.
C    IND    INTEGER
C             GT. 0  IND is a rough estimate of the number of digits
C                     of accuracy in the solution, X.  IND=75 means
C                     that the solution vector X is zero.
C             LT. 0  see error message corresponding to IND below.
C    WORK   COMPLEX(N*(N+1))
C             a singly subscripted array of dimension at least N*(N+1).
C
C  Error Messages Printed ***
C
C    IND=-1  terminal   N is greater than LDA.
C    IND=-2  terminal   N is less than one.
C    IND=-3  terminal   ITASK is less than one.
C    IND=-4  terminal   The matrix A is computationally singular
C                         or is not positive definite.
C                         A solution has not been computed.
C    IND=-10 warning    The solution has no apparent significance.
C                         the solution may be inaccurate or the matrix
C                         a may be poorly scaled.
C
C               NOTE-  the above terminal(*fatal*) error messages are
C                      designed to be handled by XERMSG in which
C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
C                      for warning error messages from XERMSG.  Unless
C                      the user provides otherwise, an error message
C                      will be printed followed by an abort.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CCOPY, CPOFA, CPOSL, DCDOT, R1MACH, SCASUM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800530  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTO's to
C           IF-THEN-ELSE.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CPOIR
C
      INTEGER LDA,N,ITASK,IND,INFO,J
      COMPLEX A(LDA,*),V(*),WORK(N,*)
      REAL SCASUM,XNORM,DNORM,R1MACH
      DOUBLE PRECISION DR1,DI1,DR2,DI2
      CHARACTER*8 XERN1, XERN2
C***FIRST EXECUTABLE STATEMENT  CPOIR
      IF (LDA.LT.N) THEN
         IND = -1
         WRITE (XERN1, '(I8)') LDA
         WRITE (XERN2, '(I8)') N
         CALL XERMSG ('SLATEC', 'CPOIR', 'LDA = ' // XERN1 //
     *      ' IS LESS THAN N = ' // XERN2, -1, 1)
         RETURN
      ENDIF
C
      IF (N.LE.0) THEN
         IND = -2
         WRITE (XERN1, '(I8)') N
         CALL XERMSG ('SLATEC', 'CPOIR', 'N = ' // XERN1 //
     *      ' IS LESS THAN 1', -2, 1)
         RETURN
      ENDIF
C
      IF (ITASK.LT.1) THEN
         IND = -3
         WRITE (XERN1, '(I8)') ITASK
         CALL XERMSG ('SLATEC', 'CPOIR', 'ITASK = ' // XERN1 //
     *      ' IS LESS THAN 1', -3, 1)
         RETURN
      ENDIF
C
      IF (ITASK.EQ.1) THEN
C
C        MOVE MATRIX A TO WORK
C
         DO 10 J=1,N
            CALL CCOPY(N,A(1,J),1,WORK(1,J),1)
   10    CONTINUE
C
C        FACTOR MATRIX A INTO R
C
         CALL CPOFA(WORK,N,N,INFO)
C
C        CHECK FOR  SINGULAR OR NOT POS.DEF. MATRIX
C
         IF (INFO.NE.0) THEN
            IND = -4
            CALL XERMSG ('SLATEC', 'CPOIR',
     *         'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1)
            RETURN
         ENDIF
      ENDIF
C
C     SOLVE AFTER FACTORING
C     MOVE VECTOR B TO WORK
C
      CALL CCOPY(N,V(1),1,WORK(1,N+1),1)
      CALL CPOSL(WORK,N,N,V)
C
C     FORM NORM OF X0
C
      XNORM = SCASUM(N,V(1),1)
      IF (XNORM.EQ.0.0) THEN
         IND = 75
         RETURN
      ENDIF
C
C     COMPUTE  RESIDUAL
C
      DO 40 J=1,N
         CALL DCDOT(J-1,-1.D0,A(1,J),1,V(1),1,DR1,DI1)
         CALL DCDOT(N-J+1,1.D0,A(J,J),LDA,V(J),1,DR2,DI2)
         DR1 = DR1+DR2-DBLE(REAL(WORK(J,N+1)))
         DI1 = DI1+DI2-DBLE(AIMAG(WORK(J,N+1)))
         WORK(J,N+1) = CMPLX(REAL(DR1),REAL(DI1))
   40 CONTINUE
C
C     SOLVE A*DELTA=R
C
      CALL CPOSL(WORK,N,N,WORK(1,N+1))
C
C     FORM NORM OF DELTA
C
      DNORM = SCASUM(N,WORK(1,N+1),1)
C
C     COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
C     AND CHECK FOR IND GREATER THAN ZERO
C
      IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM))
      IF (IND.LE.0) THEN
         IND = -10
         CALL XERMSG ('SLATEC', 'CPOIR',
     *      'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
      ENDIF
      RETURN
      END


      FUNCTION integral (n, x, y1, y2)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: n
      REAL(rprec), INTENT(IN), DIMENSION(n) :: y1, y2 , x
      REAL(rprec), PARAMETER :: one = 1
      REAL(rprec) :: h, integral
!------------------------------------------------------------------------------
!      WARNING: The integral formula assumes values on the half MESH,
!      that is, the independent variable is given from x(3/2) to x(M-1/2),
!      but the limits of the integral are x(1)=-1 and x(M)=1. N = M-1 is the
!      number of points on the half mesh.
!      In the current version, fulfilment of this condition is ONLY checked
!      for the case in which the interval of integration is the interval
!      of orthogonality of Legendre polynomias, i.e., [-1,1].
!      Integration formula is a 2-nd order HALF-MESH formula from
!      "Numerical Recipes", W.Press et al, Chapter 4, page 110.
!------------------------------------------------------------------------------
      IF (n < 10) STOP 'Too few points to carry out integration.!'
      IF (x(n) < x(1)) STOP ' B < A in INTEGRAL!'
      IF (x(n) == one .or. x(1) == -one) STOP 'HALF MESH INTEGRAL!'

      h = (x(n)-x(1))/(n-1)
      integral = h* SUM(y1*y2)

      END FUNCTION integral


      module MOD_BNUE
      contains
      PURE FUNCTION BNUE(XLAMBDA,T)
      !use MOD_ERROR
C*** PLANCK FUNCTION, LAMBDA IN ANGSTROEM, T IN KELVIN          ****************
C***  BNUE IN CGS UNITS: ERG PER CM**2, PER SEC AND PER HERTZ       ************
C***  CONSTANTS :  C1 = H * C / K   (DIMENSION ANGSTROEM * KELVIN )
C***               C2 = 2 * H * C   (DIMENSION ANGSTROEM**3  * ERG/SEC/HZ/CM**2)
      IMPLICIT NONE
      real*8 :: BNUE, cxt
      real*8,intent(in) :: XLAMBDA,T
      real*8,parameter  :: C1=1.438831D8
      real*8,parameter  :: C2=3.972967D+8

      IF (T .LE. .0) THEN
        BNUE=.0
        !print '(A,f0.2,X,f0.2)','T,XLAMBDA = ',T,XLAMBDA
      ELSE
        CXT=C1/XLAMBDA/T
        IF (CXT.GT.500.) THEN
          BNUE=0.0
        ELSE
          BNUE=C2/(EXP(CXT)-1d0)/XLAMBDA**3 !/XLAMBDA/XLAMBDA
        ENDIF
      ENDIF
      END function
      end module


C Compute the scale at a given ring radius in km/pixel.  The scale is computed
C at the point on the visible ring closest to the camera.
C
      SUBROUTINE RING_SCALE(OM,VSC,FL,OAL,OAS,SCALE,NL,NS,R,
     &		lon,srange,rline,rsamp,rscl,ascl,ind)
      IMPLICIT NONE
      REAL*8 OM(3,3)            !Camera to planet transformation matrix
      REAL*8 VSC(3)             !Vector from target center to spacecraft
      REAL*4 FL                 !Camera focal length in mm
      REAL*4 OAL,OAS            !Optical axis intercept line-sample
      REAL*4 SCALE              !Picture scale in pixels/mm
      INTEGER NL,NS		!Number of lines and samples in image
      REAL*8 R			!Input ring radius
      REAL*8 LON		!Output longitude
      REAL*8 SRANGE		!Slant range
      REAL*8 RLINE,RSAMP        !Output image coordinates
      REAL*8 RSCL,ASCL		!Radial and azimuthal ring scale (km/pixel)
      INTEGER IND		! =1 if RSCL and ASCL are valid, =0 otherwise

      REAL*8 L,S,LON0,SR,V(3),PIXELS,KILOMETERS,PI,RPD
      INTEGER I

      PI = 3.141592653589793D0
      RPD = PI/180.D0          !radians per degree

      RSCL = -999.
      ASCL = -999.
      SRANGE = 2.D+9
C     ...Scan at 1 degree increments for the point on the ring closest
C     ...to the camera (minimum slant range).
      DO 20 I=1,360
      LON0 = 1.0*I
      CALL RING_PROJ(OM,VSC,FL,OAL,OAS,SCALE,R,LON0,l,s,ind)
      IF (IND.EQ.0) GOTO 20
      IF (L.LT.1. .OR. L.GT.NL) GOTO 20
      IF (S.LT.1. .OR. S.GT.NS) GOTO 20
      V(1) = R*DCOS(LON0*RPD) - VSC(1)     !Vector from camera to ring pt
      V(2) = -R*DSIN(LON0*RPD) - VSC(2)
      V(3) =                  - VSC(3)
      SR = DSQRT(V(1)**2 + V(2)**2 + V(3)**2)    !Distance to camera
      IF (SR .GE. SRANGE) GOTO 20
      SRANGE = SR
      LON = LON0
      RLINE = L
      RSAMP = S
   20 CONTINUE

      IF (SRANGE .LT. 1.D+9) GOTO 100

C     ...Repeat scanning for the point on the ring closest to the camera,
C     ...but without restricting it to points in the image.
      DO 30 I=1,360
      LON0 = 1.0*I
      CALL RING_PROJ(OM,VSC,FL,OAL,OAS,SCALE,R,LON0,l,s,ind)
      IF (IND.EQ.0) GOTO 30
      V(1) = R*DCOS(LON0*RPD) - VSC(1)     !Vector from camera to ring pt
      V(2) = -R*DSIN(LON0*RPD) - VSC(2)
      V(3) =                  - VSC(3)
      SR = DSQRT(V(1)**2 + V(2)**2 + V(3)**2)    !Distance to camera
      IF (SR .GE. SRANGE) GOTO 30
      SRANGE = SR
      LON = LON0
      RLINE = L
      RSAMP = S
   30 CONTINUE

      IF (SRANGE .GT. 1.D+9) THEN
         SRANGE = -999.
         IND = 0
         RETURN
      ENDIF

C     ...Compute the arc length making up 1 deg of the ring in pixels
  100 CALL RING_PROJ(OM,VSC,FL,OAL,OAS,SCALE,R,LON+1.,l,s,ind)
      PIXELS = DSQRT((RLINE-L)**2 + (RSAMP-S)**2)
C     ...Compute the same arc length in kilometers: S = R*DLON
      KILOMETERS = R*RPD
      ASCL = KILOMETERS/PIXELS		!Azimuthal scale

C     ...Compute the pixels representing 1 km radial distance
      CALL RING_PROJ(OM,VSC,FL,OAL,OAS,SCALE,R+1.,LON,l,s,ind)
      PIXELS = DSQRT((RLINE-L)**2 + (RSAMP-S)**2)
      RSCL = 1./PIXELS			!Radial scale
      RETURN
      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_sgaunt

   USE m_clebsch
   USE m_constants,ONLY:pi_const

   IMPLICIT NONE

   CONTAINS
   SUBROUTINE sgaunt(lmax,c)

      !************************************************************
      !*   Calculation of the Gaunt coefficients C(L2M2,L1M1,LM)  *
      !*                                                          *
      !*    l2m2                    /         *                   *
      !*   C       =C(l2m2,l1m1,lm)=\dr*Y(r)*Y(r)*Y(r)            *
      !*    lm,l1m1                 /    lm   l1m1 l2m2           *
      !*                                                          *
      !*    and C.ne.0 when l2=/l1-l/,/l1-l/+2,...,l1+l,m2=m1-m   *
      !*    Y(lm) is a complex spherical garmonic with a phase    *
      !*    after Condon and Shortley                             *
      !* Written by S.Yu.Savrasov (P.N.Lebedev Physical Institute)*
      !************************************************************
      !*    called by umtx() ; part of the LDA+U package          *
      !*                                          G.B., Oct. 2000 *
      !************************************************************

      INTEGER, INTENT(IN)    :: lmax
      REAL,    INTENT(INOUT) :: c(0:,:,:)

      INTEGER :: l1,m1,l ,l1m1,l2,lm,m2,ll2,m
      REAL    :: aj,bj,am,bm,cj,cm,dl1,dl2,dl3,a1,a2

      DO l1 = 0,lmax
         DO m1 = -l1,l1
            DO l = 0,lmax
               DO m = -l,l
                  l1m1 = l1*(l1+1)+m1+1
                  lm   = l *(l +1)+m +1
                  DO l2 = ABS(l1-l),l1+l,2
                     ll2 = l2/2
                     m2  = m1-m
                     IF (ABS(m2).LE.l2) THEN     !!! selection rule
                        aj = REAL(l)
                        bj = REAL(l2)
                        am = REAL(m)
                        bm = REAL(m2)
                        cj = REAL(l1)
                        cm = REAL(m1)
                        a1 = clebsch(aj,bj,0.0,0.0,cj,0.0)  !!! Clebsch-Gordan coefficients
                        a2 = clebsch(aj,bj,am,bm,cj,cm)     !!! Clebsch-Gordan coefficients
                        dl1 = REAL(2*l +1)
                        dl2 = REAL(2*l2+1)
                        dl3 = REAL(2*l1+1)
                        c(ll2,l1m1,lm)=a1*a2*SQRT(dl1*dl2/dl3/4.0/pi_const)
                     ELSEIF (ABS(m2).GT.l2)THEN
                        c(ll2,l1m1,lm)=0.0
                     ENDIF
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO

   END SUBROUTINE sgaunt
END MODULE m_sgaunt


      PROGRAM xfasper
C     driver for routine fasper
      INTEGER NP,MP,NPR
      REAL TWOPI
      PARAMETER(NP=90,MP=4096,NPR=11,TWOPI=6.2831853)
      INTEGER idum,j,jmax,n,nout
      REAL gasdev,prob,x(NP),y(NP),px(MP),py(MP)
      idum=-4
      j=0
      do 11 n=1,NP+10
        if (n.ne.3.and.n.ne.4.and.n.ne.6.and.n.ne.21.and.
     *       n.ne.38.and.n.ne.51.and.n.ne.67.and.n.ne.68.and.
     *       n.ne.83.and.n.ne.93) then
          j=j+1
          x(j)=n
          y(j)=0.75*cos(0.6*x(j))+gasdev(idum)
        endif
11    continue
      call fasper(x,y,j,4.,1.,px,py,MP,nout,jmax,prob)
      write(*,*) 'FASPER results for test signal (cos(0.6x) + noise):'
      write(*,*) 'NOUT,JMAX,PROB=',nout,jmax,prob
      do 12 n=max(1,jmax-NPR/2),min(nout,jmax+NPR/2)
        write(*,*) n,TWOPI*px(n),py(n)
12    continue
      END

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


	FUNCTION TRAPEZ(Y,N,DX)
c	FINDS AREA BELOW CURVE (X,Y) ACCORDING TO TRAPEZOIDAL RULE.
c	ASSUMES EQUAL SPACING DX BETWEEN N POINTS.
	REAL Y(N)
	TRAPEZ=0.
	IF (N.LE.1) RETURN
	TRAPEZ=(Y(1) + Y(N))*DX/2.
	IF (N.EQ.2) RETURN
	A=0.
	DO I=2,N-1
	A = A + Y(I)
	ENDDO
	TRAPEZ = TRAPEZ + A*DX
	RETURN
	END


!  $Id: TestLUPIV.f90 460 2013-03-05 09:01:48Z abuttari $
!      ------------------------------------
!      Programme principal permettant
!      de tester la factorisation LU AVEC pivotage
!      d'une matrice pleine
!      ------------------------------------

program mainlu
  implicit none
  interface
     subroutine init(a, acopie, xexact, b, bcopie, x, y, r, &
          p,q,lda, n,ipivot)
       integer, intent(out) :: lda,n,ipivot
       double precision, dimension(:,:), allocatable, intent(out) :: a, acopie
       integer, dimension(:), allocatable , intent(out)           :: p,q
       double precision, dimension(:), allocatable, intent(out)   :: &
            xexact, b, bcopie, x, y, r
     end subroutine init
  end interface

  ! Dimension principale (taille de la structure de donn�e allouee en memoire)
  integer :: lda
  ! Dimension reelle du systeme a factoriser (on factorise A(1:n,1:n))
  integer :: n
  ! Matrice a factoriser et permutation P et Q
  double precision, dimension(:,:), allocatable :: a, acopie
  integer, dimension (:), allocatable           :: p, q
  ! Solution exacte, second membre, solution calculee du systeme et residu
  double precision, dimension(:), allocatable   :: xexact, b, x, &
       r, bcopie
  ! Vecteur temporaire
  double precision, dimension(:), allocatable   :: y
  ! Determinant  = DET_Mantisse * 2^DET_Exposant
  !           Pour eviter les underflows et overflows, le mantisse
  !           et l'exposant du determinant sont separees.
  double precision :: det_mantisse
  integer          :: det_exposant
  ! Scalaire local
  integer :: ierr
  ! Strat�gie de pivot
  integer :: ipivot
  ! EXTERNAL
  external norme
  double precision norme
  !
  ! --------------------------------------------
  !  Initialisation matrice A et second membre b
  ! --------------------------------------------
  !      -- definir A et Xexact puis calculer b = A xexact
  !         (faire une copie de A --> Acopie et b --> bcopie)
  !         allouer x, y et r, P

  call init(a, acopie, xexact, b, bcopie, x, y, r, p,q, lda, n,ipivot)
  ! -------------------------
  ! Factorisation de Gauss ( P A = L U ) et calcul du determinant
  ! -------------------------
!!  write(6,*) '    '
!!  write(6,*) ' ............................... '
!!  write(6,*) ' FACTORISATION LU A ECRIRE       '
!!  write(6,*) ' ............................... '
  call facto(a, lda, n,ipivot, p,q,ierr)
  write(6,*) '    '
  if(ierr==1)then
    write(6,*) 'Echec de la factorisation'

  else
    ! ----------------------
    ! Algorithme de descente     ( L y = Pb)
    ! ----------------------
    call descente ( a, lda, n, p, b, y)
    ! ----------------------
    ! Algorithme de remontee     ( U x = y )
    ! ----------------------
    call remontee ( a, lda, n, y, x)

    !------------------------------------------
    ! Analyse de l'erreur :
    !   Calcul/affichage du residu || b - A x || et
    !           du residu equilibre   || b - A x || / || |A||X| + |b| ||
    !   Calcul et affichage de || x - xexact�|| / || xexact ||
    !------------------------------------------

!!    write(6,*) '    '
!!    write(6,*) ' ............................... '
!!    write(6,*) ' ROUTINE ANALYSE ERREUR A ECRIRE '
!!    write(6,*) ' ............................... '
    call analyse_erreur (acopie,lda,n,bcopie,x,r,xexact)
    write(6,*) '    '
  endif

  deallocate (a, acopie, p, b, bcopie, x, r, y, xexact)

  stop
end program mainlu
!--------------------------------------------------------------
!--------------------------------------------------------------

!**************************************************
! Subroutines utilis�es par le programme principal
!
!
!**************************************************
subroutine init(m,mcopie,xexact,b,bcopie, &
     x,y,r,p,q,ldm,n,ipivot)
  implicit none
  ! -------------------------------------------------------------
  ! Objectif:
  ! - Tous les tableaux/matrices passes en arguments
  ! sont alloues dans la routine.
  ! - Initialisation, de la matrice M, de la solution x
  ! et du vecteur b tel que b = M x
  ! M est une matrice de dimension principale ldm avec
  ! n colonnes.
  ! Deux classes de matrices sont proposees:
  !  Classe I/
  !      -Les matrices d'ordre pair sont diagonales dominantes
  !      -Les matrices d'ordre impair ont de petites valeurs
  !         sur la diagonale et peuvent conduire � une perte
  !         de precision dans la solution
  !  Classe II/
  !      -12 matrices utilisant le generateur de LAPACK
  ! Soit x / x(i) = dble(i) on construit alors b = M x
  ! Une copie de M (-->Mcopie) et de b (--> bcopie) est effectuee
  ! --------------------------------------------------------------
  !
  interface
     subroutine matgen(imat, a, n, info)
       real(kind(1.d0)), allocatable :: a(:,:)
       integer :: imat, n, info
     end subroutine matgen
  end interface

  !  Parametres :
  !  ----------
  integer, intent(out)          :: ldm,n,ipivot
  double precision, allocatable, intent(out)  ::  &
       m(:,:), mcopie(:,:), xexact(:), &
       b(:), bcopie(:), x(:), y(:), r(:)
  integer, allocatable, intent(out)      :: p(:), q(:)

  ! Dimension maximale du systeme
  integer :: ldmmax=5000
  !
  !  Variables locales :
  !  -----------------
  integer :: i,j, ierr, classmat, imat
  logical :: pair
  !
  !  Fonctions intrinseques
  intrinsic dble, min
  !      -- taille du probleme

  classmat = 1
  ldm = -1
  n   = 0
  do while (n.gt.ldm.or. ldm.ge.ldmmax)
     write(6,*) ' Entrer la taille de la matrice lda (< ',  &
          ldmmax, ' ) ?'
     read(5,*)  ldm
     write(6,*) ' Entrer la dimension reelle n   (< ', ldm, ' ) ?'
     read(5,*)  n
     !
     write(6,*) ' Entrer la classe de matrice ', &
          ' (1 sinon 2 (generateur LAPACK))  ?'
     read(5,*)  classmat
     !
     if (classmat.eq.1) then
        !     -------------------------------
        !     Utilisation du generateur local
        !     -------------------------------
        !
        allocate(m(ldm,n), stat=ierr)
        if (ierr > 0) then
           write(6,*) ' Probleme allocation memoire :', &
                ' reduire n=', n
           stop
        endif
        !
        pair=(mod(n,2) .eq. 0)
        !      -- Initialisation de la matrice M
        !      Les matrices d'indice pair sont diagonales dominantes
        !      les matrices d'indice impair ont de petites valeurs
        !      sur la diagonale.
        if (pair)  then
           do i = 1,n
              do j=1,n
                 m(i,j) = dble(1)
              end do
              m(i,i) = dble(n+100)
           end do
        else
           do i = 1,n
              do j=1,n
                 m(i,j) = dble(i)*dble(j)
              end do
              m(i,i) = dble(i)*sqrt(epsilon(m(i,i)))
           end do
        endif
     else
        !     -------------------------------------------------------------------
        !     Utilisation du generateur de matrices pour valider les codes LAPACK
        !     -------------------------------------------------------------------
        imat = 0
        do while (imat.le.0.or.imat.gt.12)
           write(6,*) ' Generateur de matrices de LAPACK '
           write(6,*) ' Entrer le numero de la matrice entre 1 et 12 ?'
           read(5,*)  imat
        end do
        !      -- Initialisation de la matrice M
        ldm = n
        call matgen(imat, m, n, ierr)
        if (ierr.ne.0) then
           write(6,*) " Erreur dans le gnerateur LAPACK (matgen)"
           stop
        endif
     endif
     !
     !      -- allocation des structures de donn�es
     allocate (p(n),q(n), mcopie(ldm,n), b(n), bcopie(n), x(n),  &
          r(n), y(n), xexact(n), stat=ierr)

     ! Strat�gie de pivot
     write(6,*) ' Entreer la strategie de pivot ',  &
          '0: sans pivot, 1 : pivot partiel, 2 : recherche du noyau'
     read(5,*)  ipivot

  end do
  if (ierr > 0) then
     write(6,*) ' Probleme allocation memoire :', &
          ' reduire n=', n
     stop
  endif
  !     Copie de la matrice
  mcopie = m
  !      -- Initialisation de la solution exacte dans xexact
  do i=1,n
     xexact(i)   = dble(i)
  end do
  !
  !      -- Calcul de b / b = A xexact
  do i = 1, n
     b(i) = dble(0)
     do j=1,n
        b(i) = b(i) + m(i,j) * xexact(j)
     enddo
  enddo
  !      Sauvegarde de b
  bcopie = b

  !      -- impression des donnees
  if (n.le.10) then
     write (6,*) ' Matrice initiale A = '
     do i = 1,min(n,6)
        write(6,'(A,I3,6(E14.5))') ' ... Ligne ', i, m(i,1:min(n,6))
     end do
     write (6,'(A,6(E14.5))') ' xexact =', xexact(1:min(n,6))
     write (6,'(A,6(E14.5))') ' b      =', b(1:min(n,6))
  endif

  return
end subroutine init
!
!
!**************************************************
subroutine facto(m, ldm, n, ipivot, p, q, ierr)
  implicit none
  ! ------------------------------------------------------
  ! Objectifs:  Factorisation LU AVEC pivotage
  ! 1/ Calculer L / P M = L U
  !    La matrice M est de dimension principale ldm.
  !    On factorise le bloc M(1:n, 1:n)
  !    par l'algorithme de factorisation LU sans pivotage
  !    comme present� en cours.
  !
  !  Calculer le determinant
  !
  !   En entr�e la matrice M est �cras�e en sortie
  !   par les facteurs L et U.
  !
  !   IERR > 0 si un pivot trop petit
  !                   a �t� rencontr� durant factorisation
  ! ------------------------------------------------------
  !
  !  Parametres :
  !  ----------
  integer, intent(in)             :: ldm,n,ipivot
  double precision, intent(inout) :: m(ldm,n) ! matrice
  integer, intent(out)            :: p(n)     ! permutation des lignes
  integer, intent(out)             ::q(n)     ! permutation des colonnes
  integer, intent(out)            ::  ierr
  !
  ! Interface
  interface
      double precision function norme_f ( a, n,m)
      integer, intent(in)           :: n,m
      double precision, intent(in)  :: a(n,m)
      end function norme_f
  end interface

    !  Fonctions intrinseques
  intrinsic epsilon

  !  Variables locales :
  !  -----------------
  !      Indices de boucle
  integer :: i,j,k

  double precision :: eps

  ! epsilon machine (pour v�rifier si pas d pivot trop petit)
  eps = epsilon(eps)

  ! initialisation de la permutation (identit�)
  do k = 1, n
    p(k) = k
  end do

  !!!!!!!!!!!!!!!!! A ECRIRE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !!Etape de factorisation LU avec trois strat�gies de pivot :
  !! sans pivot (ipivot =0), avec pivot partiel (ipivot=1),
  !! recherche du noyau pour matrice non inversible (ipivot>1)
  do j = 1, n-1
   if (abs(m(j, j)) < eps) then
      ierr = ierr + 1
   end if
   m(j+1:n, j) = m(j+1:n, j) / m(j, j);
   !m(j+1:n, j+1:n) = m(j+1:n, j+1:n) - matmul(m(j+1:n, j), m(j, j+1:n))
  end do

  !      -- impression des donnees :
  !       -- determinant
  write(6,*) " =============================================="
  write(6,*) " Fin de la FACTORISATION "
  write(6,*) " ========================"
  write(6,*) " ... AFFICHER DETERMINANT de la matrice "

  if (n.le.6) then
     write (6,*) ' ... Matrice factorisee par ligne :  '
     do i = 1,n
        write(6,'(6(E14.5))')  m(i,1:n)
     end do
     write (6,*) " ... Permutation P : ", P(1:n)
     write (6,*) " ... Permutation Q : ", Q(1:n)
  endif
  write(6,*) " =============================================="

  return
end subroutine facto

!**************************************************
subroutine descente (m,ldm,n,p,b,x)
  implicit none
  ! -----------------------------------------------------------
  ! Objectif:
  ! Resoudre L x = P b avec
  ! L la partie triangulaire inferieure de la matrice M,
  ! de dimension principale ldm et de n colonnes.
  ! Algorithme avec report:
  !   cet algorithme a assez naturellement tendance
  !   � modifier le second membre ce qui n'est
  !   ni une bonne propriete ni
  !   indispensable comme le montre l'implementation fournie ici
  ! -------------------------------------------------------------
  !
  !  Parametres :
  !  ----------
  integer, intent(in)           :: ldm,n
  double precision, intent(in)  :: m(ldm,n)
  integer, intent(in)           :: p(n)
  !      attention assez naturellement on va
  !      lors du report modifier b
  !         ( MAIS uniquement si on est peu attentif !)
  double precision, intent(in)  :: b(n)
  double precision, intent(out) :: x(n)
  !
  !  Variables locales :
  !  -----------------
  !      Indices de boucle
  integer :: i,j
  double precision :: xtemp
  !
  !       Algorithme avec report sans modification de b
  !

  x = b

  ! Ecrire la prise en compte de la permutation P en permutant
  ! le second membre qui est maintenant dans x
  write(6,*)"Descente : permutation P non prise en compte"

  do i = 1, n
      ! calcul du x(i)
      ! L a des 1 sur la diagonale (non stockes dans M!)
      ! report de la connaissance de x(i) sur es second membres.
      ! pour eviter de modifier b on note
      ! qu'a chaque etape i, les parties
      ! modifiees de b et calculees de x forment une partition de {1,..,n}
      do j = i+1, n
        !            --- avec modification de b:
        !            --- b(j) = b(j) - M(j,i) * x(i)
        !            sans modification de b:
        x(j) = x(j) - m(j,i) * x(i)
      end do
  end do
  !       write (6,*) " En sortie de la descente Ly = b: "
  !       write (6,'(A,6(E14.5))') '    b      =', b(1:min(n,6))
  !       write (6,'(A,6(E14.5))') '    y      =', x(1:min(n,6))

  return
end subroutine descente
!
!**************************************************
subroutine remontee (m,ldm,n,b,x)
  implicit none
  ! ------------------------------------------------------
  ! Objectif:
  ! Resoudre U  x = b avec
  ! U la partie triangulaire superieure de la matrice M,
  ! de dimension principale ldm et de n colonnes.
  ! Algorithme sans report.
  ! ------------------------------------------------------
  !
  !  Parametres :
  !  ----------
  integer, intent(in)           :: ldm,n
  double precision, intent(in)  :: m(ldm,n), b(n)
  double precision, intent(out) :: x(n)
  !
  !  Variables locales :
  !  -----------------
  !      Indices de boucle
  integer :: i,j
  ! Permutation
  double precision :: xtemp

  !      Algorithme sans report.
  do i = n, 1, -1
      x(i)  = b(i)
      ! on reporte la connaissance des x(j) pour j> i
      ! et on va chercher M(i,j) dans la triangulaire inferieure
      do j = i+1, n
         x(i) = x(i) - m(i,j) * x(j)
      end do
      x(i) = x(i) / m(i,i)
  end do

  !       write (6,*) " En sortie de la remontee Ux = y: "
  !       write (6,'(A,6(E14.5))') '    y      =', b(1:min(n,6))
  !       write (6,'(A,6(E14.5))') '    x      =', x(1:min(n,6))
  return
end subroutine remontee

!**************************************************
subroutine analyse_erreur(m,ldm,n,b,x,r,xexact)
  implicit none
  ! ------------------------------------------------------------
  ! Objectif:
  ! Analyse de l'erreur :
  !   Calcul et affichage de || b - M x || / || |M||X| + |b| ||
  !   Calcul et affichage de || x - xexact�|| / || xexact ||
  ! M etant une matrice carree de
  ! dimension principale ldm et de n colonnes.
  ! -------------------------------------------------------------
  !
  !  Parametres :
  !  ----------
  integer, intent(in)           :: ldm,n
  double precision, intent(in)  :: m(ldm,n), x(n), b(n)
  double precision, intent(out) :: r(n)
  double precision, intent(in)  :: xexact(n)

  ! Interfaces
  interface
      double precision function norme ( x, n)
      integer, intent(in)           :: n
      double precision, intent(in)  :: x(n)
      end function norme

      double precision function norme_f ( a, n,m)
      integer, intent(in)           :: n,m
      double precision, intent(in)  :: a(n,m)
      end function norme_f
  end interface

  !
  !  Variables locales :
  !  -----------------
  !      Indices de boucles
  integer :: i, j

!!!!!!!!!!!!!!!!! A ECRIRE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Calcul et affichage de des erreurs relatives directe et inverse
!! Calcul et afffichage de la norme du r�sidu
  write(6,*) "Analyse erreur non faite "

  write(6,*) "  "
  write(6,*) " =============================================="
  write(6,*) " Analyse d'ERREUR "
  write(6,*) " ================ "
  write(6,'(A,6(E14.5))') '  xexact   =', xexact(1:min(n,6))
  write(6,'(A,6(E14.5))') '  xcalcule =', x(1:min(n,6))
  write(6,*) " =============================================="

  return
end subroutine analyse_erreur

!**************************************************
subroutine noyau (m,ldm,n,q,kstop,x)
  implicit none
  ! ------------------------------------------------------
  ! Objectif:
  ! Calculer une base du noyau depuis la factorisation incomplete
  ! Arret de la factosiation � l'�tape kstop
  !  Ker (AQ) = Im[-U11^(-1)*U12;Ir]
  !
  !
  ! ------------------------------------------------------
  !
  !  Parametres :
  !  ----------
  integer, intent(in)           :: ldm,n,kstop
  double precision, intent(in)  :: m(ldm,n) ! facto LU incomplete de PAQ
  integer, intent(in)           :: q(n) ! permutation des colonnes
  double precision, intent(out) :: x(n,n-kstop+1) ! base du noyau
  !
  !  Variables locales :
  !  -----------------
  !      Indices de boucle
  integer :: i,j,l

  !!!!!!!!!!!!!!!!! A ECRIRE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Calcul d'une base du noyau de A

  write (6,*) "Base du noyau non calculee"

  return
end subroutine noyau

!**************************************************
double precision function norme ( x, n)
  implicit none
  ! ---------------------------------------
  ! Objectif: NORME = || x || , with 2 norm
  ! ----------------------------------------
  integer, intent(in)           :: n
  double precision, intent(in)  :: x(n)
  !
  !  Variables locales :
  !  -----------------
  !      Indices de boucles
  integer :: i
  !
  !  Fonctions intrinseques
  intrinsic sqrt, dble

  norme = dble(0)
  do i=1, n
     norme = norme + x(i) *x(i)
  enddo
  norme = sqrt(norme)

  return
end function norme

!**************************************************
double precision function norme_f ( a, n,m)
  implicit none
  ! ---------------------------------------
  ! Objectif: NORME_F = || A ||, avec norme de Frobenius
  ! ----------------------------------------
  integer, intent(in)           :: n, m
  double precision, intent(in)  :: a(n,m)
  !
  !  Variables locales :
  !  -----------------
  !      Indices de boucles
  integer :: i,j
  !
  !  Fonctions intrinseques
  intrinsic sqrt, dble

  norme_f = dble(0)
  do j=1,m
    do i=1,n
       norme_f = norme_f + a(i,j)*a(i,j)
    enddo
  enddo
  norme_f = sqrt(norme_f)

  return
end function norme_f


*DECK CINVIT
      SUBROUTINE CINVIT (NM, N, AR, AI, WR, WI, SELECT, MM, M, ZR, ZI,
     +   IERR, RM1, RM2, RV1, RV2)
C***BEGIN PROLOGUE  CINVIT
C***PURPOSE  Compute the eigenvectors of a complex upper Hessenberg
C            associated with specified eigenvalues using inverse
C            iteration.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C2B
C***TYPE      COMPLEX (INVIT-S, CINVIT-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure CXINVIT
C     by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C     This subroutine finds those eigenvectors of A COMPLEX UPPER
C     Hessenberg matrix corresponding to specified eigenvalues,
C     using inverse iteration.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, AR, AI, ZR and ZI, as declared in the
C          calling program dimension statement.  NM is an INTEGER
C          variable.
C
C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        AR and AI contain the real and imaginary parts, respectively,
C          of the complex upper Hessenberg matrix.  AR and AI are
C          two-dimensional REAL arrays, dimensioned AR(NM,N)
C          and AI(NM,N).
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues of the matrix.  The eigenvalues must be
C          stored in a manner identical to that of subroutine  COMLR,
C          which recognizes possible splitting of the matrix.  WR and
C          WI are one-dimensional REAL arrays, dimensioned WR(N) and
C          WI(N).
C
C        SELECT specifies the eigenvectors to be found.  The
C          eigenvector corresponding to the J-th eigenvalue is
C          specified by setting SELECT(J) to .TRUE.  SELECT is a
C          one-dimensional LOGICAL array, dimensioned SELECT(N).
C
C        MM should be set to an upper bound for the number of
C          eigenvectors to be found.  MM is an INTEGER variable.
C
C     On OUTPUT
C
C        AR, AI, WI, and SELECT are unaltered.
C
C        WR may have been altered since close eigenvalues are perturbed
C          slightly in searching for independent eigenvectors.
C
C        M is the number of eigenvectors actually found.  M is an
C          INTEGER variable.
C
C        ZR and ZI contain the real and imaginary parts, respectively,
C          of the eigenvectors corresponding to the flagged eigenvalues.
C          The eigenvectors are normalized so that the component of
C          largest magnitude is 1.  Any vector which fails the
C          acceptance test is set to zero.  ZR and ZI are
C          two-dimensional REAL arrays, dimensioned ZR(NM,MM) and
C          ZI(NM,MM).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          -(2*N+1)   if more than MM eigenvectors have been requested
C                     (the MM eigenvectors calculated to this point are
C                     in ZR and ZI),
C          -K         if the iteration corresponding to the K-th
C                     value fails (if this occurs more than once, K
C                     is the index of the last occurrence); the
C                     corresponding columns of ZR and ZI are set to
C                     zero vectors,
C          -(N+K)     if both error situations occur.
C
C        RV1 and RV2 are one-dimensional REAL arrays used for
C          temporary storage, dimensioned RV1(N) and RV2(N).
C          They hold the approximate eigenvectors during the inverse
C          iteration process.
C
C        RM1 and RM2 are two-dimensional REAL arrays used for
C          temporary storage, dimensioned RM1(N,N) and RM2(N,N).
C          These arrays hold the triangularized form of the upper
C          Hessenberg matrix used in the inverse iteration process.
C
C     The ALGOL procedure GUESSVEC appears in CINVIT in-line.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C     Calls CDIV for complex division.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  CDIV, PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CINVIT
C
      INTEGER I,J,K,M,N,S,II,MM,MP,NM,UK,IP1,ITS,KM1,IERR
      REAL AR(NM,*),AI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*)
      REAL RM1(N,*),RM2(N,*),RV1(*),RV2(*)
      REAL X,Y,EPS3,NORM,NORMV,GROWTO,ILAMBD,RLAMBD,UKROOT
      REAL PYTHAG
      LOGICAL SELECT(N)
C
C***FIRST EXECUTABLE STATEMENT  CINVIT
      IERR = 0
      UK = 0
      S = 1
C
      DO 980 K = 1, N
         IF (.NOT. SELECT(K)) GO TO 980
         IF (S .GT. MM) GO TO 1000
         IF (UK .GE. K) GO TO 200
C     .......... CHECK FOR POSSIBLE SPLITTING ..........
         DO 120 UK = K, N
            IF (UK .EQ. N) GO TO 140
            IF (AR(UK+1,UK) .EQ. 0.0E0 .AND. AI(UK+1,UK) .EQ. 0.0E0)
     1         GO TO 140
  120    CONTINUE
C     .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
C                (HESSENBERG) MATRIX ..........
  140    NORM = 0.0E0
         MP = 1
C
         DO 180 I = 1, UK
            X = 0.0E0
C
            DO 160 J = MP, UK
  160       X = X + PYTHAG(AR(I,J),AI(I,J))
C
            IF (X .GT. NORM) NORM = X
            MP = I
  180    CONTINUE
C     .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
C                AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
         IF (NORM .EQ. 0.0E0) NORM = 1.0E0
         EPS3 = NORM
  190    EPS3 = 0.5E0*EPS3
         IF (NORM + EPS3 .GT. NORM) GO TO 190
         EPS3 = 2.0E0*EPS3
C     .......... GROWTO IS THE CRITERION FOR GROWTH ..........
         UKROOT = SQRT(REAL(UK))
         GROWTO = 0.1E0 / UKROOT
  200    RLAMBD = WR(K)
         ILAMBD = WI(K)
         IF (K .EQ. 1) GO TO 280
         KM1 = K - 1
         GO TO 240
C     .......... PERTURB EIGENVALUE IF IT IS CLOSE
C                TO ANY PREVIOUS EIGENVALUE ..........
  220    RLAMBD = RLAMBD + EPS3
C     .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
  240    DO 260 II = 1, KM1
            I = K - II
            IF (SELECT(I) .AND. ABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
     1         ABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
  260    CONTINUE
C
         WR(K) = RLAMBD
C     .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I
C                AND INITIAL COMPLEX VECTOR ..........
  280    MP = 1
C
         DO 320 I = 1, UK
C
            DO 300 J = MP, UK
               RM1(I,J) = AR(I,J)
               RM2(I,J) = AI(I,J)
  300       CONTINUE
C
            RM1(I,I) = RM1(I,I) - RLAMBD
            RM2(I,I) = RM2(I,I) - ILAMBD
            MP = I
            RV1(I) = EPS3
  320    CONTINUE
C     .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
C                REPLACING ZERO PIVOTS BY EPS3 ..........
         IF (UK .EQ. 1) GO TO 420
C
         DO 400 I = 2, UK
            MP = I - 1
            IF (PYTHAG(RM1(I,MP),RM2(I,MP)) .LE.
     1         PYTHAG(RM1(MP,MP),RM2(MP,MP))) GO TO 360
C
            DO 340 J = MP, UK
               Y = RM1(I,J)
               RM1(I,J) = RM1(MP,J)
               RM1(MP,J) = Y
               Y = RM2(I,J)
               RM2(I,J) = RM2(MP,J)
               RM2(MP,J) = Y
  340       CONTINUE
C
  360       IF (RM1(MP,MP) .EQ. 0.0E0 .AND. RM2(MP,MP) .EQ. 0.0E0)
     1         RM1(MP,MP) = EPS3
            CALL CDIV(RM1(I,MP),RM2(I,MP),RM1(MP,MP),RM2(MP,MP),X,Y)
            IF (X .EQ. 0.0E0 .AND. Y .EQ. 0.0E0) GO TO 400
C
            DO 380 J = I, UK
               RM1(I,J) = RM1(I,J) - X * RM1(MP,J) + Y * RM2(MP,J)
               RM2(I,J) = RM2(I,J) - X * RM2(MP,J) - Y * RM1(MP,J)
  380       CONTINUE
C
  400    CONTINUE
C
  420    IF (RM1(UK,UK) .EQ. 0.0E0 .AND. RM2(UK,UK) .EQ. 0.0E0)
     1      RM1(UK,UK) = EPS3
         ITS = 0
C     .......... BACK SUBSTITUTION
C                FOR I=UK STEP -1 UNTIL 1 DO -- ..........
  660    DO 720 II = 1, UK
            I = UK + 1 - II
            X = RV1(I)
            Y = 0.0E0
            IF (I .EQ. UK) GO TO 700
            IP1 = I + 1
C
            DO 680 J = IP1, UK
               X = X - RM1(I,J) * RV1(J) + RM2(I,J) * RV2(J)
               Y = Y - RM1(I,J) * RV2(J) - RM2(I,J) * RV1(J)
  680       CONTINUE
C
  700       CALL CDIV(X,Y,RM1(I,I),RM2(I,I),RV1(I),RV2(I))
  720    CONTINUE
C     .......... ACCEPTANCE TEST FOR EIGENVECTOR
C                AND NORMALIZATION ..........
         ITS = ITS + 1
         NORM = 0.0E0
         NORMV = 0.0E0
C
         DO 780 I = 1, UK
            X = PYTHAG(RV1(I),RV2(I))
            IF (NORMV .GE. X) GO TO 760
            NORMV = X
            J = I
  760       NORM = NORM + X
  780    CONTINUE
C
         IF (NORM .LT. GROWTO) GO TO 840
C     .......... ACCEPT VECTOR ..........
         X = RV1(J)
         Y = RV2(J)
C
         DO 820 I = 1, UK
            CALL CDIV(RV1(I),RV2(I),X,Y,ZR(I,S),ZI(I,S))
  820    CONTINUE
C
         IF (UK .EQ. N) GO TO 940
         J = UK + 1
         GO TO 900
C     .......... IN-LINE PROCEDURE FOR CHOOSING
C                A NEW STARTING VECTOR ..........
  840    IF (ITS .GE. UK) GO TO 880
         X = UKROOT
         Y = EPS3 / (X + 1.0E0)
         RV1(1) = EPS3
C
         DO 860 I = 2, UK
  860    RV1(I) = Y
C
         J = UK - ITS + 1
         RV1(J) = RV1(J) - EPS3 * X
         GO TO 660
C     .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
  880    J = 1
         IERR = -K
C     .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
  900    DO 920 I = J, N
            ZR(I,S) = 0.0E0
            ZI(I,S) = 0.0E0
  920    CONTINUE
C
  940    S = S + 1
  980 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
C                SPACE REQUIRED ..........
 1000 IF (IERR .NE. 0) IERR = IERR - N
      IF (IERR .EQ. 0) IERR = -(2 * N + 1)
 1001 M = S - 1
      RETURN
      END


program test_fluid
  use fluid
  implicit none
  ! Fluid solver class.
  type(FluidSlv) :: FldSlv2D, FldSlv3D
  ! Names of variables.
  character(len=:), dimension(:), allocatable :: names2D, names3D
  ! Dimensions of the simulation domains.
  integer :: whd2D(2), whd3D(3)
  ! Simulation parameters.
  real(dp) :: scale, safety
  ! Density.
  real(dp) :: rho, timestep
  ! Add in flow coordinates.
  type(Vec2D2) :: xi2D
  type(Vec2D)  :: xi
  real(dp) :: initial_cond(3)
  ! Time
  real(dp) :: t
  ! Timers
  integer :: startvalues(8), endvalues(8), startcount, endcount
  real(4) :: countrate
  ! Counter
  integer :: i, j
  ! Arrays
  real(dp), allocatable :: u(:,:), prhs(:)
  real(dp) :: celsiz
  real(dp) :: coefficients(16)

  ! Initialise names.
  allocate(character(len=8) :: names2D(4))

  ! Test 2D.1: Initialise Fluid.
  ! Safety factor.
  safety = 1._dp
  ! Grid scale.
  scale = 1._dp
  ! 10x10 2D grid with sides of length 3 (each box is of size 1x1).
  whd2D = 5
  ! Density.
  rho = 0.1_dp
  ! Initial timestep.
  timestep = 0.005
  ! Names
  names2D(1)(:) = "Density."
  names2D(2)(:) = "Vx."
  names2D(3)(:) = "Vy."
  call FldSlv2D % Init(names2D, whd2D, rho, timestep, scale, safety)

  xi2D % x = [0.2_dp, .7_dp, 0.2_dp, 0.7_dp]
  initial_cond = [5.0_dp, 1.0_dp, 1.0_dp]
  xi % x = [0.5_dp, 0.5_dp]

  call FldSlv2D % InitFlow(xi2D, initial_cond)

  print*, "Slow Cubic interpolation: ", FldSlv2D % u(1) % Cerp(xi), new_line(new_line(""))

  coefficients = FldSlv2D % u(1) % BcC2D(xi)

  do i = 1, 16
    print*,i, coefficients(i)
  end do
  print*, new_line(new_line(""))

  print*, "Quick Cubic interpolation: ", FldSlv2D % u(1) % QuickCerp2D(xi, FldSlv2D % u(1) % BcC2D(xi)), new_line(new_line(""))
end program test_fluid


      REAL FUNCTION CSEDVIS(SED)
      REAL::SED,VISR,WTL,WTH,VISL,VISH
C CHANGE RECORD
C
C
C **  CALCULATES KINEMATIC VISCOSITY OF HIGH CONCENTRATION COHESIVE
C **  SEDIMENT-WATER MIXTURE BASED ON
C **
C **  MEHTA, A. J., AND F.JIANG, 1990: SOME OBSERVATIONS ON BOTTOM
C **  MUD MOTION DUE TO WAVES. COASTAL AND OCEANOGRAPHIC ENGINEERING
C **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
C
      IF(SED.LE.25667.) VISR=0.116883E-3*SED
      IF(SED.GE.36667.) VISR=1.52646E-6*SED+3.125
      IF(SED.GT.25667.0.AND.SED.LT.36667.0)THEN
        WTL=(36667.-SED)/11000.
        WTH=(SED-25667.)/11000.
        VISL=0.116883E-3*25667
        VISH=1.52646E-6*36667.+3.125
        VISR=WTL*VISL+WTH*VISH
      ENDIF
      CSEDVIS=1.E-6*(10.**VISR)
      RETURN
      END


module fcn_mxsquared_px
    use mod_kinds,      only: rk,ik
    use type_function,  only: function_t
    use type_point,     only: point_t
    use mod_constants,   only: ONE
    implicit none
    private

    !>  x-squared function.
    !!
    !!  \f$     f(t,\vec{x}) = x^2  \f$
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !-------------------------------------------------------------------------
    type, extends(function_t), public :: mxsquared_px_f

    contains

        procedure   :: init
        procedure   :: compute

    end type mxsquared_px_f
    !**************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(mxsquared_px_f),  intent(inout)   :: self

        !
        ! Set function name
        !
        call self%set_name("-x_squared+x")

        !
        ! Set function options to default settings
        !

    end subroutine init
    !*************************************************************************

    !>
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !!
    !--------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(mxsquared_px_f),  intent(inout)  :: self
        real(rk),           intent(in)  :: time
        type(point_t),      intent(in)  :: coord

        real(rk)                        :: val

        ! f(x) = -x**2+x
        val = -(ONE) * coord%c1_  *  coord%c1_ + coord%c1_

    end function compute
    !**************************************************************************

end module fcn_mxsquared_px


subroutine sum(x, res)
  implicit none
  real, intent(in) :: x(:)
  real, intent(out) :: res

  integer :: i

  !print *, "sum: size(x) = ", size(x)

  res = 0.0

  do i = 1, size(x)
    res = res + x(i)
  enddo

end subroutine sum

function fsum(x) result (res)
  implicit none
  real, intent(in) :: x(:)
  real :: res

  integer :: i

  !print *, "fsum: size(x) = ", size(x)

  res = 0.0

  do i = 1, size(x)
    res = res + x(i)
  enddo

end function fsum


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

C ... Calculate nodal volume...

      SUBROUTINE PRNVOL (NDIM, CRD, IX, NUMNP, NUMEL, NNODE,
     &  VOLUME, IUNIT)

      DIMENSION CRD(NUMNP, *), IX(NNODE,*)
      DIMENSION GRADOP(8)
      REAL volume(*)

      IF (NDIM .EQ. 3 .AND. NNODE .EQ. 8) THEN
        do 10 i = 1, numnp
          volume(i) = 0.0
 10     continue

        DO 20 IEL = 1, numel
          y1 = crd(ix(1,iel),2)
          y2 = crd(ix(2,iel),2)
          y3 = crd(ix(3,iel),2)
          y4 = crd(ix(4,iel),2)
          y5 = crd(ix(5,iel),2)
          y6 = crd(ix(6,iel),2)
          y7 = crd(ix(7,iel),2)
          y8 = crd(ix(8,iel),2)

          Z1 = crd(ix(1,iel),3)
          Z2 = crd(ix(2,iel),3)
          Z3 = crd(ix(3,iel),3)
          Z4 = crd(ix(4,iel),3)
          Z5 = crd(ix(5,iel),3)
          Z6 = crd(ix(6,iel),3)
          Z7 = crd(ix(7,iel),3)
          Z8 = crd(ix(8,iel),3)

          Z24 = Z2 - Z4
          Z52 = Z5 - Z2
          Z45 = Z4 - Z5
          GRADOP(1) = ( Y2*(Z6-Z3-Z45) + Y3*Z24 + Y4*(Z3-Z8-Z52)
     *      + Y5*(Z8-Z6-Z24) + Y6*Z52 + Y8*Z45 ) / 12.
          Z31 = Z3 - Z1
          Z63 = Z6 - Z3
          Z16 = Z1 - Z6
          GRADOP(2) = ( Y3*(Z7-Z4-Z16) + Y4*Z31 + Y1*(Z4-Z5-Z63)
     *      + Y6*(Z5-Z7-Z31) + Y7*Z63 + Y5*Z16 ) / 12.
          Z42 = Z4 - Z2
          Z74 = Z7 - Z4
          Z27 = Z2 - Z7
          GRADOP(3) = ( Y4*(Z8-Z1-Z27) + Y1*Z42 + Y2*(Z1-Z6-Z74)
     *      + Y7*(Z6-Z8-Z42) + Y8*Z74 + Y6*Z27 ) / 12.
          Z13 = Z1 - Z3
          Z81 = Z8 - Z1
          Z38 = Z3 - Z8
          GRADOP(4) = ( Y1*(Z5-Z2-Z38) + Y2*Z13 + Y3*(Z2-Z7-Z81)
     *      + Y8*(Z7-Z5-Z13) + Y5*Z81 + Y7*Z38 ) / 12.
          Z86 = Z8 - Z6
          Z18 = Z1 - Z8
          Z61 = Z6 - Z1
          GRADOP(5) = ( Y8*(Z4-Z7-Z61) + Y7*Z86 + Y6*(Z7-Z2-Z18)
     *      + Y1*(Z2-Z4-Z86) + Y4*Z18 + Y2*Z61 ) / 12.
          Z57 = Z5 - Z7
          Z25 = Z2 - Z5
          Z72 = Z7 - Z2
          GRADOP(6) = ( Y5*(Z1-Z8-Z72) + Y8*Z57 + Y7*(Z8-Z3-Z25)
     *      + Y2*(Z3-Z1-Z57) + Y1*Z25 + Y3*Z72 ) / 12.
          Z68 = Z6 - Z8
          Z36 = Z3 - Z6
          Z83 = Z8 - Z3
          GRADOP(7) = ( Y6*(Z2-Z5-Z83) + Y5*Z68 + Y8*(Z5-Z4-Z36)
     *      + Y3*(Z4-Z2-Z68) + Y2*Z36 + Y4*Z83 ) / 12.
          Z75 = Z7 - Z5
          Z47 = Z4 - Z7
          Z54 = Z5 - Z4
          GRADOP(8) = ( Y7*(Z3-Z6-Z54) + Y6*Z75 + Y5*(Z6-Z1-Z47)
     *      + Y4*(Z1-Z3-Z75) + Y3*Z47 + Y1*Z54 ) / 12.

          EVOL = crd(ix(1,iel),1) * GRADOP(1)
     *      + crd(ix(2,iel),1) * GRADOP(2)
     *      + crd(ix(3,iel),1) * GRADOP(3)
     *      + crd(ix(4,iel),1) * GRADOP(4)
     *      + crd(ix(5,iel),1) * GRADOP(5)
     *      + crd(ix(6,iel),1) * GRADOP(6)
     *      + crd(ix(7,iel),1) * GRADOP(7)
     *      + crd(ix(8,iel),1) * GRADOP(8)
          if (volume(iel) .lt. 0.0) then
            write (*,*) 'Zero or negative volume at element',
     &        iel
          endif

          do 15 i=1, 8
            node = ix(i,iel)
            volume(node) = volume(node) + EVOL / 8.0
 15       continue
 20     CONTINUE

C ... Special for Frank Dempsey -- Print volumes and connectivity to file
        tvol = 0.0
        DO 30 I=1, NUMNP
          write (IUNIT,999) i, volume(i)
          tvol = tvol + volume(i)
 999      format(i8,1PE17.8)
 30     CONTINUE
        write (iunit, 998) tvol
 998    format(/,'Total Volume = ',1pe17.8)
      ELSE
        STOP 'Not Implemented'
      END IF
      RETURN
      END


SUBROUTINE elmat(area,rho,emm)
!
! This subroutine forms the "analytical" lumped mass matrix for
! quadrilateral 4- or 8-node plane strain elements.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::area,rho
 REAL(iwp),INTENT(OUT)::emm(:,:)
 REAL(iwp)::zero=0.0_iwp,pt2=0.2_iwp,pt25=0.25_iwp
 INTEGER::i,ndof
 ndof=UBOUND(emm,1)
 emm=zero
 SELECT CASE(ndof)
 CASE(8)
   DO i=1,8
     emm(i,i)=pt25*area*rho
   END DO
 CASE(16)
   DO i=1,16
     emm(i,i)=pt2*area*rho
   END DO
   DO i=1,13,4
     emm(i,i)=pt25*emm(3,3)
   END DO
   DO i=2,14,4
     emm(i,i)=pt25*emm(3,3)
   END DO
 CASE DEFAULT
   WRITE(*,*)"Wrong number of nodes for rectangular element"
 END SELECT
RETURN
END SUBROUTINE elmat


SUBROUTINE interp(k,dtim,rt,rl,al,nstep)
!
! This subroutine forms the load/time functions by interpolation.
! If dtim is not an exact multiple it stops one short.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::dtim,rt(:),rl(:)
 INTEGER,INTENT(IN)::k,nstep
 REAL(iwp),INTENT(IN OUT)::al(:,:)
 INTEGER::np,i,j
 REAL(iwp)::t,val
 np=SIZE(rt)
 al(1,k)=rl(1)
 t=rt(1)
 DO j=2,nstep
   t=t+dtim
   DO i=2,np
     IF(t.LE.rt(i))THEN
       val=rl(i-1)+((t-rt(i-1))/(rt(i)-rt(i-1)))*(rl(i)-rl(i-1))
       EXIT
     END IF
   END DO
   al(j,k)=val
 END DO
RETURN
END SUBROUTINE interp


c
c spatialFilter routine -- Apply a fixed spatial filter (smoother) in lat/lon and then average over times/grids
c
c Designed to be called from python using f2py.
c
c
c Low Pass Filter = 1/9  * [1 1 1         ! normalization = 9
c                           1 1 1
c                           1 1 1]
c
c Gaussian Filter = 1/16 * [1 2 1         ! normalization = 16
c                           2 4 2
c                           1 2 1]
c

      subroutine spatialFilter_f(var, mask,
     &                         time, lat, lon,
     &                         filter, normalization,
     &                         missingValue,
     &                         verbose,
     &                         vinterp, vcount, status,
     &                         ntime, nlat, nlon)

      implicit none
      integer*4 ntime, nlat, nlon
c                 ! prepared 3D array of variable data over time, lon, & lat
      real*4    var(ntime, nlat, nlon)
c                 ! variable to be interpolated, over ntime epochs
      integer*1 mask(ntime, nlat, nlon)
c                 ! pixel quality mask
      integer*4 time(ntime)
c                 ! time epochs to gaussian-interpolate over
      real*4 lat(nlat)
                  ! latitude corrdinate vector
      real*4 lon(nlon)
                  ! longitude corrdinate vector
cf2py intent(in) var, mask, time, lat, lon        !! annotations for f2py processor

      integer*4 filter(3, 3)
c                 ! 3x3 filter coefficients as integers
      integer*4 normalization
c                 ! Normalization factor for the filter, divide by sum of integers
cf2py intent(in) filter, normalization

      real*4 missingValue
c                 ! value to mark missing values in interp result
      integer*4 verbose
c                 ! integer to set verbosity level
cf2py intent(in) missingValue, verbose

      real*4 vinterp(nlat, nlon)
c                 ! interpolated variable using gaussians, missing values not counted
      integer*4 vcount(nlat, nlon)
c                 ! count of good data, might be zero after masking
      integer*4 status
c                 ! negative status indicates error
cf2py intent(out) vinterp, vcount, status

      integer*4 iin, jin, kin
      integer*4 i, j, fac, count
      real*4 val, sum

      write(6, *) 'Echoing inputs ...'
      write(6, *) 'ntime, nlat, nlon:', ntime, nlat, nlon
      write(6, *) 'filter:', filter
      write(6, *) 'normalization', normalization
      write(6, *) 'missingValue:', missingValue

      status = 0

      if (verbose .gt. 3) then
          write(6, *) 'time:', time
          write(6, *) 'lat:', lat
          write(6, *) 'lon:', lon
c          write(6, *) 'mask(3):', mask(3,:,:)
          write(6, *) 'var(3):', var(3,:,:)
      end if

      do i = 1, nlat
         if (verbose .gt. 1) write(6, *) lat(i)
         do j = 1, nlon
            vinterp(i,j) = 0.0
            vcount(i,j) = 0.0
            if (verbose .gt. 3) then
               write(6, *) '(i,j) = ', i, j
               write(6, *) '(lat,lon) = ', lat(i), lon(j)
            end if

            do kin = 1, ntime
               sum = 0.0
               count = 0
               do iin = -1, +1
                  if (i+iin .lt. 1 .or. i+iin .gt. nlat) cycle
                  do jin = -1, +1
                     if (j+jin .lt. 1 .or. j+jin .gt. nlon) cycle

                     if (mask(kin,iin,jin) .eq. 0) then
                        fac = filter(iin+2, jin+2)
                        val = var(kin,iin,jin)
                        sum = sum + fac * val
                        count = count + fac
                     end if
                  end do
               end do
               if (count .gt. 0) then
c                 ! filter for (i,j) pixel isn't empty
                  vinterp(i,j) = vinterp(i,j) + sum / normalization
                  vcount(i,j) = vcount(i,j) + 1
               end if
            end do
            if (vcount(i,j) .gt. 0) then
               vinterp(i,j) = vinterp(i,j) / vcount(i,j)
c              ! compute mean over number of non-empty times/grids
            else
               vinterp(i,j) = missingValue
            end if
         end do
      end do
      return
      end