PROGRAM histo_test

use mo_kind, only: dp, i4
use mo_ansi_colors, only: color, c_red, c_green
#ifndef __ABSOFT__
use mo_histo, only: histo

implicit none

real(dp), dimension(10)                :: x_dp
real(dp), dimension(5,3)               :: x_dp_2d
real(dp), allocatable, dimension(:)    :: binx_dp
real(dp), allocatable, dimension(:,:)  :: binx_dp_2d
real(dp)                               :: w_dp

logical , dimension(10)                :: maske
integer(i4), allocatable, dimension(:) :: bincount

real(dp),    dimension(:),   allocatable :: Has2Be_binx_dp
real(dp),    dimension(:,:), allocatable :: Has2Be_binx_dp_2d
integer(i4), dimension(:),   allocatable :: Has2Be_bincount

integer(i4)                            :: i,n

print*, '  '
print*, 'YOUR DATA:'
x_dp = (/ 1.2_dp, 1.5_dp, 3.4_dp, 5.3_dp , 6.3_dp, 7.2_dp, 1.8_dp, 5.4_dp, 4.3_dp , 10.3_dp /)
print*, '# Values: ',size(x_dp)
print*, x_dp
print*, '  '
print*, '----------------------------'
print*, '  '

print*, 'Histogram (default)'
call histo(x_dp,binx_dp,bincount,w_dp)

n = size(binx_dp,1)
do i=1,n
   print '(A4,I2,A8,F8.3,A13,I3)', &
         'Bin(',i,'): x = (',binx_dp(i),')   Bincount: ',bincount(i)
end do
print*, '  '

allocate(Has2Be_bincount(3), Has2Be_binx_dp(3))
Has2Be_binx_dp  = (/2.717_dp, 5.750_dp, 8.783_dp/)
Has2Be_bincount = (/4, 5, 1/)
if ( all(bincount .eq. Has2Be_bincount) .and. &
     all(nint(binx_dp*1000.0_dp) .eq. nint(Has2Be_binx_dp*1000.0_dp))) then
   print*, 'mo_histo: default ', color('o.k.', c_green)
else
   print*, 'mo_histo: default ', color('failed', c_red)
end if
deallocate(Has2Be_bincount, Has2Be_binx_dp)

print*, '  '
print*, '----------------------------'
print*, '  '

print*, 'Histogram (bins=7)'
call histo(x_dp,binx_dp,bincount,w_dp,bins=7)

n = size(binx_dp,1)
do i=1,n
   print '(A4,I2,A8,F8.3,A13,I3)', &
         'Bin(',i,'): x = (',binx_dp(i),')   Bincount: ',bincount(i)
end do
print*, '  '

allocate(Has2Be_bincount(n), Has2Be_binx_dp(n))
Has2Be_binx_dp  = (/1.850_dp, 3.150_dp, 4.450_dp, 5.750_dp, 7.050_dp,9.650_dp/)
Has2Be_bincount = (/3,1,1,3,1,1/)
if ( all(bincount .eq. Has2Be_bincount) .and. &
     all(nint(binx_dp*1000.0_dp) .eq. nint(Has2Be_binx_dp*1000.0_dp))) then
   print*, 'mo_histo: fixed number of bins ', color('o.k.', c_green)
else
   print*, 'mo_histo: fixed number of bins ', color('failed', c_red)
end if
deallocate(Has2Be_bincount, Has2Be_binx_dp)

print*, '  '
print*, '----------------------------'
print*, '  '

print*, 'Histogram (binwidth=1.5)'
call histo(x_dp,binx_dp,bincount,w_dp,binwidth=1.5_dp)

n = size(binx_dp,1)
do i=1,n
   print '(A4,I2,A8,F8.3,A13,I3)', &
         'Bin(',i,'): x = (',binx_dp(i),')   Bincount: ',bincount(i)
end do
print*, '  '

allocate(Has2Be_bincount(n), Has2Be_binx_dp(n))
Has2Be_binx_dp  = (/1.950_dp, 3.450_dp, 4.950_dp, 6.450_dp, 7.950_dp,10.950_dp/)
Has2Be_bincount = (/3,1,3,1,1,1/)
if ( all(bincount .eq. Has2Be_bincount) .and. &
     all(nint(binx_dp*1000.0_dp) .eq. nint(Has2Be_binx_dp*1000.0_dp))) then
   print*, 'mo_histo: fixed width of bins ', color('o.k.', c_green)
else
   print*, 'mo_histo: fixed width of bins ', color('failed', c_red)
end if
deallocate(Has2Be_bincount, Has2Be_binx_dp)

print*, '  '
print*, '----------------------------'
print*, '  '

print*, 'Histogram (mask= TTTTT FFFFF)'
maske = .false.
do i=1,5
   maske(i) = .true.
end do

call histo(x_dp,binx_dp,bincount,w_dp,mask=maske)

n = size(binx_dp,1)
do i=1,n
   print '(A4,I2,A8,F8.3,A13,I3)', &
         'Bin(',i,'): x = (',binx_dp(i),')   Bincount: ',bincount(i)
end do
print*, '  '

allocate(Has2Be_bincount(n), Has2Be_binx_dp(n))
Has2Be_binx_dp  = (/2.475_dp, 5.025_dp/)
Has2Be_bincount = (/3,2/)
if ( all(bincount .eq. Has2Be_bincount) .and. &
     all(nint(binx_dp*1000.0_dp) .eq. nint(Has2Be_binx_dp*1000.0_dp))) then
   print*, 'mo_histo: with mask ', color('o.k.', c_green)
else
   print*, 'mo_histo: with mask ', color('failed', c_red)
end if
deallocate(Has2Be_bincount, Has2Be_binx_dp)

print*, '  '
print*, '----------------------------'
print*, '  '

print*, '  '
print*, 'YOUR DATA:'
x_dp_2d(:,1) = (/ 1.2_dp, 1.5_dp, 3.4_dp, 5.3_dp , 6.3_dp /)
x_dp_2d(:,2) = (/ 10.0_dp, 8.0_dp, 4.0_dp, 3.0_dp , 3.0_dp /)
x_dp_2d(:,3) = (/ 7.0_dp, 5.0_dp, 3.0_dp, 3.0_dp , 4.0_dp /)
print*, '# Values:  ( ',size(x_dp_2d,1),' , ',size(x_dp_2d,2),' )'
print*, 'x(:,1) = ',x_dp_2d(:,1)
print*, 'x(:,2) = ',x_dp_2d(:,2)
print*, 'x(:,3) = ',x_dp_2d(:,3)
print*, '  '
print*, '----------------------------'
print*, '  '

print*, 'Histogram (default)'
call histo(x_dp_2d(:,1),binx_dp,bincount,w_dp)

n = size(binx_dp,1)
do i=1,n
   print '(A4,I2,A8,F8.3,A13,I3)', &
         'Bin(',i,'): x = (',binx_dp(i),')   Bincount: ',bincount(i)
end do
print*, '  '

print*, 'Histogram (with averaging)'
call histo(x_dp_2d,binx_dp_2d,bincount,w_dp)

n = size(binx_dp,1)
do i=1,n
   print '(A4,I2,A8,F8.3,A3,F8.3,A3,F8.3,A13,I3)', &
         'Bin(',i,'): x = (',binx_dp_2d(i,1),',',binx_dp_2d(i,2),',',binx_dp_2d(i,3),')   Bincount: ',bincount(i)
end do
print*, '  '

allocate(Has2Be_bincount(2), Has2Be_binx_dp_2d(2,3))
Has2Be_binx_dp_2d(1,:)  = (/2.475_dp, 7.333_dp, 5.000_dp/)
Has2Be_binx_dp_2d(2,:)  = (/5.025_dp, 3.000_dp, 3.500_dp/)
Has2Be_bincount = (/3,2/)
if ( all(bincount .eq. Has2Be_bincount) .and. &
     all(nint(binx_dp_2d*1000.0_dp) .eq. nint(Has2Be_binx_dp_2d*1000.0_dp))) then
#endif
   print*, 'mo_histo: with averaging (default) ', color('o.k.', c_green)
#ifndef __ABSOFT__
else
   print*, 'mo_histo: with averaging (default) ', color('failed', c_red)
end if
deallocate(Has2Be_bincount, Has2Be_binx_dp_2d)

print*, '  '
print*, '----------------------------'
print*, '  '
#endif

END PROGRAM histo_test


program Wavelets
    use fixed_array
    use zfp_array
    use wavelet
    use lz4
    use, intrinsic :: ieee_arithmetic
    implicit none

    integer(kind=4), parameter :: N = 4
    integer i, j

    real(kind=4), dimension(N, N) :: x, x_in
    real(kind=4), dimension(N, N) :: y
    logical(kind=1), dimension(N, N) :: mask
    character(kind=c_char), allocatable :: mask_buffer(:)
    character(kind=c_char), allocatable :: array_buffer(:)

    type(fixed_block), dimension(N/4, N/4) :: compressed
    type(fixed_block) :: compressed_block
    integer :: x1, x2, y1, y2
    integer :: max_exp

    integer, dimension(4, 4) :: e

    ! FORTRAN-native ZFP
    type(zfp_block) :: compressed2
    integer(kind=2) :: bitmask

    do i = 1, N
        do j = 1, N
            x(i, j) = i*j
        end do
    end do

    ! insert a NaN value
    x(N/2, N/2) = ieee_value(0.0, ieee_quiet_nan)

    print *, 'BEFORE'
    do i = 1, N
        print *, x(i, :)
    end do

    ! a forward 2D wavelet transform
    call daub4_2Dtransform(N, x, y, mask)

    ! count the number of 0.0 coefficients
    print *, '# of zero coefficients:', count(y .eq. 0.0)

    print *, 'AFTER'
    do i = 1, N
        print *, y(i, :)
    end do

    ! an inverse transform to recover the data
    call daub4_2Dtransform_inv(N, y, x, mask)

    print *, 'RECOVERED'
    do i = 1, N
        print *, x(i, :)
    end do

    ! reset the source
    do i = 1, N
        do j = 1, N
            x(i, j) = (i - 2)*(j - 2)/10.0
        end do
    end do

    ! insert a NaN value
    x(N/2, N/2) = ieee_value(0.0, ieee_quiet_nan)

    print *, 'X:'
    do i = 1, N
        print *, x(i, :)
    end do

    ! an in-place transform
    call daub4_2Dtransform_inpl(n, x, mask)

    ! count the number of 0.0 coefficients
    print *, '# of zero coefficients:', count(x .eq. 0.0)

    print *, 'MASK'
    do i = 1, N
        print *, mask(i, :)
    end do

    print *, 'COEFFS:'
    do i = 1, N
        print *, x(i, :)
    end do

    ! an in-place inverse transform
    call daub4_2Dtransform_inv_inpl(n, x, mask)

    print *, 'RECOVERED'
    do i = 1, N
        print *, x(i, :)
    end do

    ! ZFP-like fixed-point 4x4 block with a common exponent

    ! reset the source
    do i = 1, N
        do j = 1, N
            x(i, j) = (i - 2)*(j - 2)/1000.0
        end do
    end do

    ! insert a NaN value
    x(N/2, N/2) = ieee_value(0.0, ieee_quiet_nan)

    !  pick out all the NaN
    where (isnan(x))
        mask = .false.
    elsewhere
        mask = .true.
    end where

    ! replace NaNs with 0.0
    ! where (.not. mask) x = 0.0

    print *, 'minexponent', minexponent(0.0)
    print *, 'e', exponent(x)

    ! ZFP-like compression
    call to_fixed(x, compressed, -1000.0, -100.0, 100.0, minval(x), maxval(x))

    call print_fixed_block(compressed(1, 1))

    ! testing irregular blocks
    x1 = 1
    x2 = 4
    y1 = 1
    y2 = 4

    x_in = ieee_value(0.0, ieee_quiet_nan)
    x_in(x1:x2, y1:y2) = x(x1:x2, y1:y2)

    print *, 'x_in'
    do i = 1, N
        print *, x_in(i, :)
    end do

    e = exponent(x)
    max_exp = minexponent(0.0)

    do j = 1, 4
        do i = 1, 4
            if (.not. isnan(x(i, j))) then
                ! ignore zero values when looking for the maximum exponent
                if (abs(x(i, j)) .gt. 0.0) then
                    if (e(i, j) .gt. max_exp) then
                        max_exp = e(i, j)
                        print *, 'x', x(i, j), 'e', e(i, j), 'max_exp', max_exp
                    end if
                end if
            end if
        end do
    end do

    print *, 'block max_exp', max_exp

    ! call to_fixed_block(x_in, compressed_block)
    ! call from_fixed_block(compressed_block, x)

    print *, 'sizeof(x):', sizeof(x), ', compressed size:', sizeof(compressed)
    print *, 'compression ratio:', real(sizeof(x))/real(sizeof(compressed))

    ! call LZ4-HC to compress the mask
    ! call compress_mask(mask, mask_buffer)

    ! compress the fixed array
    ! call compress_fixed_array(compressed, array_buffer)

    ! decompress mask
    ! call decompress_mask(mask_buffer, mask)

    ! call decompress_fixed_array(array_buffer, compressed)

    ! ZFP-like decompression
    call from_fixed(N, compressed, x, minval(x), maxval(x))

    ! insert back NaN values
    ! where (.not. mask) x = ieee_value(0.0, ieee_quiet_nan)

    print *, 'FIXED-POINT DECOMPRESSION'
    do i = 1, N
        print *, x(i, :)
    end do

    print *, compressed
    print *, mask

    call zfp_compress_block(x, compressed2)
    call zfp_decompress_block(compressed2, x, bitmask)

    print *, 'native ZFP decompression', x
    write (*, '(a,b32.32)') 'bitmask ', bitmask

end program Wavelets


subroutine get_backward_euler_rhs(t, dt, q, r, rhs)

! Calculates the RHS for use with backward Euler
!
! Args:
!   t: Time at the beginning of the current step.
!   dt: Length of the current time step.
!   q: Solution values at beginning of current step.
!   r: Current Newton iterate
!   rhs: Returns the RHS.

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t, dt
    double precision, intent(in), dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: q, r
    double precision, intent(out), dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: rhs
    integer :: ix, iy, ieqn

    call apply_bcs(t + dt, r)
    call apply_pde_operator(t, r, rhs)

    do ieqn = 1, meqn
        !$omp parallel do private(ix)
        do iy = 1, my
            do ix = 1, mx
                rhs(ix, iy, ieqn) = q(ix, iy, ieqn) - r(ix, iy, ieqn)  &
                    + dt * rhs(ix, iy, ieqn)
            end do
        end do
    end do

end subroutine get_backward_euler_rhs


! ###################################################################
! Copyright (c) 2013-2022, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:math.f90
!--------------------------------------------------------------------------
!
! MODULE: math
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief collection of mathematical/numerical routines that don't fit anywhere else
!
!> @date 10/13/98 MDG 1.0 original
!> @date 05/19/01 MDG 2.0 f90
!> @date 11/27/01 MDG 2.1 added kind support
!> @date 03/19/13 MDG 3.0 updated all routines
!> @date 11/13/13 MDG 4.0 added MatrixExponential routine
!> @date 11/23/15 MDG 4.1 moved several routines from other mods into this one
!> @date 10/24/17 MDG 4.2 added infty()/inftyd() functions to return the IEEE infinity value
!> @date 08/23/19 MDG 4.3 removed spaces around "kind" statements to facilitate f90wrap python wrapper generation
!> @date 10/04/19 MDG 4.4 adds vecnorm to replace non-standard NORM2 calls  (F2003 compliance)
!> @date 10/04/19 MDG 4.5 adds nan() function, returning a single or double precision IEEE NaN value
!> @date 11/01/19 MDG 4.6 adds Jaccard_Distance routine (moved from Indexingmod)
!--------------------------------------------------------------------------
! ###################################################################
!

module mod_math
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! collection of mathematical/numerical routines that don't fit anywhere else (no classes, just routines)

use mod_kinds
use mod_global

! public :: mInvert, cross3, infty, inftyd, nan, nan_d,

interface mInvert
        module procedure mInvert
        module procedure mInvert_d
end interface

interface cross3
        module procedure cross3
        module procedure cross3_d
end interface

interface vecnorm
        module procedure vecnorm
        module procedure vecnorm_d
        module procedure vecnorm2
        module procedure vecnorm2_d
end interface

contains

!--------------------------------------------------------------------------
recursive function vecnorm(vec) result(veclen)
!DEC$ ATTRIBUTES DLLEXPORT :: vecnorm
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! return the single precision length of a 1D vector

real(kind=sgl),INTENT(IN)        :: vec(:)
real(kind=sgl)                   :: veclen

integer(kind=irg)                :: sz(1)

sz = size(vec)

veclen = sqrt(sum(vec(1:sz(1))*vec(1:sz(1))))

end function vecnorm

!--------------------------------------------------------------------------
recursive function vecnorm_d(vec) result(veclen)
  !DEC$ ATTRIBUTES DLLEXPORT :: vecnorm_d
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! return the double precision length of a 1D vector

real(kind=dbl),INTENT(IN)       :: vec(:)
real(kind=dbl)                  :: veclen

integer(kind=irg)               :: sz(1)

sz = size(vec)

veclen = sqrt(sum(vec(1:sz(1))*vec(1:sz(1))))

end function vecnorm_d

!--------------------------------------------------------------------------
recursive function vecnorm2(vec) result(veclen)
!DEC$ ATTRIBUTES DLLEXPORT :: vecnorm2
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! return the single precision length of a 2D array

real(kind=sgl),INTENT(IN)        :: vec(:,:)
real(kind=sgl)                   :: veclen

integer(kind=irg)                :: sz(2)

sz = size(vec)

veclen = sqrt(sum(vec(1:sz(1),1:sz(2))*vec(1:sz(1),1:sz(2))))

end function vecnorm2

!--------------------------------------------------------------------------
recursive function vecnorm2_d(vec) result(veclen)
!DEC$ ATTRIBUTES DLLEXPORT :: vecnorm2_d
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! return the double precision length of a 2D array

real(kind=dbl),INTENT(IN)        :: vec(:,:)
real(kind=dbl)                   :: veclen

integer(kind=irg)                :: sz(2)

sz = size(vec)

veclen = sqrt(sum(vec(1:sz(1),1:sz(2))*vec(1:sz(1),1:sz(2))))

end function vecnorm2_d

!--------------------------------------------------------------------------
recursive function infty() result(infinity)
!DEC$ ATTRIBUTES DLLEXPORT :: infty
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! return the single precision IEEE value for infinity

real(kind=sgl)      :: infinity
real(kind=sgl)      :: big

big = HUGE(1.0)
infinity = big + HUGE(1.0)

end function infty

!--------------------------------------------------------------------------
recursive function inftyd() result(infinity)
!DEC$ ATTRIBUTES DLLEXPORT :: inftyd
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! return the double precision IEEE value for infinity

real(kind=dbl)      :: infinity
real(kind=dbl)      :: big

big = HUGE(1.D0)
infinity = big + HUGE(1.D0)

end function inftyd

!--------------------------------------------------------------------------
recursive function nan() result(x)
!DEC$ ATTRIBUTES DLLEXPORT :: nan
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! return the single precision IEEE value for nan

 use, intrinsic :: iso_fortran_env
 use, intrinsic :: ieee_arithmetic

 IMPLICIT NONE

real(kind=sgl)        :: x

x = ieee_value(x, ieee_quiet_nan)

end function nan

!--------------------------------------------------------------------------
recursive function nan_d() result(x)
!DEC$ ATTRIBUTES DLLEXPORT :: nan_d
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! return the double precision IEEE value for nan

 use, intrinsic :: iso_fortran_env
 use, intrinsic :: ieee_arithmetic

 IMPLICIT NONE

real(kind=dbl)        :: x

x = ieee_value(x, ieee_quiet_nan)

end function nan_d

!--------------------------------------------------------------------------
!
! FUNCTION: cross3
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @brief  cross product of two 3D vector in the order of input
!
!
!> @param u input vector 1
!> @param v input vector 2
!
!> @date 03/03/16   SS 1.0 original
!> @date 12/01/16  MDG 1.1 split in single and double precision versions
!--------------------------------------------------------------------------
recursive function cross3(u, v) result(res)
!DEC$ ATTRIBUTES DLLEXPORT :: cross3

IMPLICIT NONE

real(kind=sgl),INTENT(IN)      :: u(3)
real(kind=sgl),INTENT(IN)      :: v(3)
real(kind=sgl)                 :: res(3)

res(1) = u(2)*v(3) - u(3)*v(2)
res(2) = u(3)*v(1) - u(1)*v(3)
res(3) = u(1)*v(2) - u(2)*v(1)

end function cross3

!--------------------------------------------------------------------------
!
! FUNCTION: cross3_d
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @brief  cross product of two 3D vector in the order of input (double precision)
!
!
!> @param u input vector 1
!> @param v input vector 2
!
!> @date 03/03/16   SS 1.0 original
!--------------------------------------------------------------------------
recursive function cross3_d(u, v) result(res)
!DEC$ ATTRIBUTES DLLEXPORT :: cross3_d

IMPLICIT NONE

real(kind=dbl),INTENT(IN)      :: u(3)
real(kind=dbl),INTENT(IN)      :: v(3)
real(kind=dbl)                 :: res(3)

res(1) = u(2)*v(3) - u(3)*v(2)
res(2) = u(3)*v(1) - u(1)*v(3)
res(3) = u(1)*v(2) - u(2)*v(1)

end function cross3_d

!--------------------------------------------------------------------------
recursive subroutine mInvert_d(a,b,uni)
!DEC$ ATTRIBUTES DLLEXPORT :: mInvert_d
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! Invert a 3x3 matrix; if unitary, simply transpose

use mod_io

IMPLICIT NONE

real(kind=dbl),INTENT(IN)               :: a(3,3)
 !! input matrix
real(kind=dbl),INTENT(OUT)              :: b(3,3)
 !! output matrix
logical,INTENT(IN)                      :: uni
 !! unitary logical

type(IO_T)                              :: Message
real(kind=dbl)                          :: d
integer(kind=irg)                       :: i, j

! it is a regular (non-unitary) matrix
 if (.not.uni) then
  d = a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+ &
         a(1,3)*a(2,1)*a(3,2)-a(1,3)*a(2,2)*a(3,1)- &
         a(1,2)*a(2,1)*a(3,3)-a(1,1)*a(2,3)*a(3,2)
  if (d.ne.0.D0) then
   b(1,1)=a(2,2)*a(3,3)-a(2,3)*a(3,2)
   b(1,2)=a(1,3)*a(3,2)-a(1,2)*a(3,3)
   b(1,3)=a(1,2)*a(2,3)-a(1,3)*a(2,2)
   b(2,1)=a(2,3)*a(3,1)-a(2,1)*a(3,3)
   b(2,2)=a(1,1)*a(3,3)-a(1,3)*a(3,1)
   b(2,3)=a(1,3)*a(2,1)-a(1,1)*a(2,3)
   b(3,1)=a(2,1)*a(3,2)-a(2,2)*a(3,1)
   b(3,2)=a(1,2)*a(3,1)-a(1,1)*a(3,2)
   b(3,3)=a(1,1)*a(2,2)-a(1,2)*a(2,1)
   b = b/d
  else
    do i=1,3
      write (*,*) (a(i,j),j=1,3)
    end do
!  call Message%printError('mInvert','matrix has zero determinant')
   call Message%printMessage('mInvert: matrix has zero determinant')
   b = a
  end if
 else
! it is a unitary matrix, so simply get the transpose
  b = transpose(a)
 endif

end subroutine mInvert_d

!--------------------------------------------------------------------------
recursive subroutine mInvert(a,b,uni)
!DEC$ ATTRIBUTES DLLEXPORT :: mInvert
  !! author: MDG
  !! version: 1.0
  !! date: 01/17/20
  !!
  !! Invert a single precision 3x3 matrix; if unitary, simply transpose

use mod_io

IMPLICIT NONE

real(kind=sgl),INTENT(IN)               :: a(3,3)
 !! input matrix
real(kind=sgl),INTENT(OUT)              :: b(3,3)
 !! output matrix
logical,INTENT(IN)                      :: uni
 !! unitary logical

type(IO_T)                              :: Message
real(kind=sgl)                          :: d                    !< auxiliary variable
integer(kind=irg)                       :: i, j
! it is a regular (non-unitary) matrix
 if (.not.uni) then
  d = a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+ &
         a(1,3)*a(2,1)*a(3,2)-a(1,3)*a(2,2)*a(3,1)- &
         a(1,2)*a(2,1)*a(3,3)-a(1,1)*a(2,3)*a(3,2)
  if (d.ne.0.0) then
   b(1,1)=a(2,2)*a(3,3)-a(2,3)*a(3,2)
   b(1,2)=a(1,3)*a(3,2)-a(1,2)*a(3,3)
   b(1,3)=a(1,2)*a(2,3)-a(1,3)*a(2,2)
   b(2,1)=a(2,3)*a(3,1)-a(2,1)*a(3,3)
   b(2,2)=a(1,1)*a(3,3)-a(1,3)*a(3,1)
   b(2,3)=a(1,3)*a(2,1)-a(1,1)*a(2,3)
   b(3,1)=a(2,1)*a(3,2)-a(2,2)*a(3,1)
   b(3,2)=a(1,2)*a(3,1)-a(1,1)*a(3,2)
   b(3,3)=a(1,1)*a(2,2)-a(1,2)*a(2,1)
   b = b/d
  else
    do i=1,3
      write (*,*) (a(i,j),j=1,3)
    end do
!  call Message%printError('mInvert','matrix has zero determinant')
   call Message%printMessage('mInvert: matrix has zero determinant')
   b = a
  end if
 else
! it is a unitary matrix, so simply get the transpose
  b = transpose(a)
 endif

end subroutine mInvert

end module mod_math


Module PolyMapMod
  use MathFuncMod

  implicit none
  type  polymap
    integer :: dim
    integer, private :: max_order
    integer, allocatable, dimension(:,:) :: map
    integer(kind=4) :: totallength
  contains
    PROCEDURE, PASS :: set => setindexmap
    PROCEDURE, PASS :: dec => decomposite
  end type polymap

  interface polymap
    module procedure constructor
  end interface

contains

    function constructor(dim,order) result(this)
        implicit none
        type(polymap) :: this
        integer, intent(in) :: dim,order
        !write(*,*) 'Constructor works'
        this%dim   = dim
        this%max_order = order

        call setindexMap(this)
    end function

    subroutine polymap_destructor(this)
        type(polymap) :: this
        !write(*,*) 'Destructor works'
        if (ALLOCATED(this % map)) deallocate(this % map)
    end subroutine

    ! implement instance constructor with arguments
    subroutine setindexmap(this)
      class (polymap) :: this
      integer(kind=4) :: totallength
      integer :: i
      totallength = binomial(this%max_order+this%dim, this%dim)
      this%totallength = totallength
      if (.not. ALLOCATED(this % map)) allocate(this % map(this%dim+1,totallength))
      this %map = 0

      do i=1,totallength
        call decomposite(this,i-1,this % map(:,i))
      enddo

    end subroutine setindexmap

    subroutine decomposite(this,n,results)
      class (polymap) :: this
      integer n,itemp,i,k
      integer :: results(this%dim+1)

      itemp = n+1
      do i = this%dim,1,-1
        k=i-1
        do while (binomial(k, i)<itemp)
          k=k+1
        enddo
        itemp=itemp-binomial(k-1, i)
        results(this%dim-i+1)=k-i
      enddo
      do i = this%dim,1,-1
        results(i+1)=results(i)-results(i+1)
      enddo
      !if (n==0) write(*,*) results
    end subroutine decomposite

End Module PolyMapMod


! Process a 2-d gaussian entropy pulse and compare it to the analytic solution for calculating the l1 norm
! this is based off of Castro_radiation/fgaussianpulse.f90
!
! this is used to analyze data from the test_diffusion test problem
!
! NOTE: THIS IS NOT MULTILEVEL AWARE
!

program fnorm

  use f2kcli
  use bl_space
  use bl_error_module
  use bl_constants_module
  use bl_IO_module
  use plotfile_module

  implicit none

  type(plotfile) pf
  integer :: unit
  integer :: i, j, ii, jj
  real(kind=dp_t) :: xx, yy

  real(kind=dp_t) :: dx(MAX_SPACEDIM)
  real(kind=dp_t) :: npts

  real(kind=dp_t) :: xctr, yctr, time, dist

  ! data for the analytic solution
  real(kind=dp_t) :: t0, h0, hp, D, analytic_solution

  real(kind=dp_t), pointer :: p(:,:,:,:)

  integer :: rhoh_comp, rho_comp

  integer :: lo(MAX_SPACEDIM), hi(MAX_SPACEDIM)

  character(len=256) :: pltfile

  integer :: narg, farg
  character(len=256) :: fname

  real(kind=dp_t) :: l1

  unit = unit_new()

  ! set the defaults
  pltfile  = ''
  t0 = 0.1d0
  D = 0.32009079924505196d0
  hp = TEN
  h0 = ONE

  l1 = ZERO
  npts = ZERO

  narg = command_argument_count()

  farg = 1
  do while ( farg <= narg )
     call get_command_argument(farg, value = fname)

     select case (fname)

     case ('-p', '--pltfile')
        farg = farg + 1
        call get_command_argument(farg, value = pltfile)

     case ('-h0')
        farg = farg + 1
        call get_command_argument(farg, value = fname)
        read(fname,*) h0

     case ('-t0')
        farg = farg + 1
        call get_command_argument(farg, value = fname)
        read(fname,*) t0

     case ('-hp')
        farg = farg + 1
        call get_command_argument(farg, value = fname)
        read(fname,*) hp

     case ('-D')
        farg = farg + 1
        call get_command_argument(farg, value = fname)
        read(fname,*) D

     case default
        exit

     end select
     farg = farg + 1
  end do

  if ( len_trim(pltfile) == 0 ) then
     print *, "usage: fgaussianpulse args"
     print *, "args [-p|--pltfile]   plotfile   : plot file directory (required)"
     print *, "     [-h0] background_enthalpy; default is ZERO"
     print *, "     [-t0] initial time; default is 0.1"
     print *, "     [-hp] peak_enthalpy; default is TEN"
     print *, "     [-D] diffusion_coefficient; default is 0.32009079924505196d0 "
     print *, '     based on the dump_gnuplot_analysis in test_diffusion/varden.f90'
     stop
  end if

  call build(pf, pltfile, unit)

  do i = 1, pf%flevel
     call fab_bind_level(pf, i)
  end do

  time = pf%tm

  dx = plotfile_get_dx(pf,pf%flevel)

  ! find the center coordinate
  xctr = HALF * (pf%phi(1) - pf%plo(1))
  yctr = HALF * (pf%phi(2) - pf%plo(2))

  ! figure out the variable indices
  rhoh_comp = -1
  do i = 1, pf%nvars
     if (pf%names(i) == "rhoh") then
        rhoh_comp = i
        exit
     endif
  enddo
  if (rhoh_comp < 0) call bl_error("rhoh not found")

  rho_comp = -1
  do i = 1, pf%nvars
     if (pf%names(i) == "density") then
        rho_comp = i
        exit
     endif
  enddo
  if (rho_comp < 0) call bl_error("density not found")

  do i = pf%flevel, 1, -1

     do j = 1, nboxes(pf, i)
        lo = lwb(get_box(pf, i, j))
        hi = upb(get_box(pf, i, j))

        ! get a pointer to the current patch
        p => dataptr(pf, i, j)

        ! loop over all of the zones in the patch.
        do jj = lbound(p,dim=2), ubound(p,dim=2)
           yy = (jj + HALF)*dx(2)

           do ii = lbound(p,dim=1), ubound(p,dim=1)
              npts = npts + ONE

              xx = (ii + HALF)*dx(1)

              dist = sqrt((xx-xctr)**2 + (yy-yctr)**2)
              analytic_solution = f(time,dist)

                 l1 = l1 + abs(analytic_solution - &
                      p(ii,jj,1,rhoh_comp)/p(ii,jj,1,rho_comp))

           end do
        enddo

     end do

  end do

  ! normalize
  l1 = l1 / npts

  print *, time, l1

  do i = 1, pf%flevel
     call fab_unbind_level(pf, i)
  end do

  call destroy(pf)

contains

  function f(t,x) result(r)
    real(kind=dp_t) :: t, x
    real(kind=dp_t) :: r

    r = (hp-h0)*(t0/(t+t0))*dexp(-x*x/(FOUR*D*(t+t0))) + h0
  end function f

end program fnorm


*     ***************************************
*     *										*
*     *      fcoord_to_real					*
*     *										*
*     ***************************************
*
*     This routine converts from fractional coordinates to real
*     coordinates.
*
*     Entry - nion
*             a(3,3): lattice vectors
*             ion: fractional coordinates
*    Exit -
*             ion: real coordinates
*

      subroutine fcoord_to_real(nion,ion)
      implicit none
      integer nion
      real*8 ion(3,*)

c     **** local variables ****
      integer i,j
      real*8 tion(3)
      real*8 a(3,3)

*     *** external functions ****
      real*8   lattice_unita
      external lattice_unita

      do j=1,3
      do i=1,3
        a(i,j) = lattice_unita(i,j)
      end do
      end do

      do i=1,nion
         tion(1) = ion(1,i)
         tion(2) = ion(2,i)
         tion(3) = ion(3,i)

         ion(1,i) = a(1,1)*tion(1)
     >            + a(1,2)*tion(2)
     >            + a(1,3)*tion(3)
         ion(2,i) = a(2,1)*tion(1)
     >            + a(2,2)*tion(2)
     >            + a(2,3)*tion(3)
         ion(3,i) = a(3,1)*tion(1)
     >            + a(3,2)*tion(2)
     >            + a(3,3)*tion(3)
      end do

      return
      end

*     ***************************************
*     *										*
*     *      fcoord_to_frac 				*
*     *										*
*     ***************************************
*
*     This routine converts from real coordinates to fractional
*     coordinates.
*
*     Entry - nion
*             a(3,3): lattice vectors
*             ion: real coordinates
*     Exit -
*             ion: fractional coordinates

      subroutine fcoord_to_frac(nion,ion)
      implicit none
      integer nion
      real*8 ion(3,*)

*     **** local variables ****
      integer i,j
      real*8 a(3,3),b(3,3),volume
      real*8 tion(3)

*     *** external functions ****
      real*8   lattice_unita
      external lattice_unita

      do j=1,3
      do i=1,3
        a(i,j) = lattice_unita(i,j)
      end do
      end do

      b(1,1) = a(2,2)*a(3,3) - a(3,2)*a(2,3)
      b(2,1) = a(3,2)*a(1,3) - a(1,2)*a(3,3)
      b(3,1) = a(1,2)*a(2,3) - a(2,2)*a(1,3)
      b(1,2) = a(2,3)*a(3,1) - a(3,3)*a(2,1)
      b(2,2) = a(3,3)*a(1,1) - a(1,3)*a(3,1)
      b(3,2) = a(1,3)*a(2,1) - a(2,3)*a(1,1)
      b(1,3) = a(2,1)*a(3,2) - a(3,1)*a(2,2)
      b(2,3) = a(3,1)*a(1,2) - a(1,1)*a(3,2)
      b(3,3) = a(1,1)*a(2,2) - a(2,1)*a(1,2)
      volume = a(1,1)*b(1,1)
     >       + a(2,1)*b(2,1)
     >       + a(3,1)*b(3,1)

      volume = 1.0d0/volume
      call dscal(9,volume,b,1)

      do i=1,nion
         tion(1) = ion(1,i)
         tion(2) = ion(2,i)
         tion(3) = ion(3,i)
         ion(1,i) = b(1,1)*tion(1)
     >            + b(2,1)*tion(2)
     >            + b(3,1)*tion(3)

         ion(2,i) = b(1,2)*tion(1)
     >            + b(2,2)*tion(2)
     >            + b(3,2)*tion(3)

         ion(3,i) = b(1,3)*tion(1)
     >            + b(2,3)*tion(2)
     >            + b(3,3)*tion(3)

      end do

      return
      end

c $Id$


      SUBROUTINE MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, LDA,
     $                   B, LDB, Y, JPVT, RANK, SVAL, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute a solution, optionally corresponding to specified free
C     elements, to a real linear least squares problem:
C
C         minimize || A * X - B ||
C
C     using a complete orthogonal factorization of the M-by-N matrix A,
C     which may be rank-deficient.
C
C     Several right hand side vectors b and solution vectors x can be
C     handled in a single call; they are stored as the columns of the
C     M-by-NRHS right hand side matrix B and the N-by-NRHS solution
C     matrix X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies whether or not a standard least squares solution
C             must be computed, as follows:
C             = 'L':  Compute a standard least squares solution (Y = 0);
C             = 'F':  Compute a solution with specified free elements
C                     (given in Y).
C
C     INIPER  CHARACTER*1
C             Specifies whether an initial column permutation, defined
C             by JPVT, must be performed, as follows:
C             = 'P':  Perform an initial column permutation;
C             = 'N':  Do not perform an initial column permutation.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     NRHS    (input) INTEGER
C             The number of right hand sides, i.e., the number of
C             columns of the matrices B and X.  NRHS >= 0.
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of A, which
C             is defined as the order of the largest leading triangular
C             submatrix R11 in the QR factorization with pivoting of A,
C             whose estimated condition number is less than 1/RCOND.
C             0 <= RCOND <= 1.
C
C     SVLMAX  (input) DOUBLE PRECISION
C             If A is a submatrix of another matrix C, and the rank
C             decision should be related to that matrix, then SVLMAX
C             should be an estimate of the largest singular value of C
C             (for instance, the Frobenius norm of C).  If this is not
C             the case, the input value SVLMAX = 0 should work.
C             SVLMAX >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading M-by-N part of this array must
C             contain the given matrix A.
C             On exit, the leading M-by-N part of this array contains
C             details of its complete orthogonal factorization:
C             the leading RANK-by-RANK upper triangular part contains
C             the upper triangular factor T11 (see METHOD);
C             the elements below the diagonal, with the entries 2 to
C             min(M,N)+1 of the array DWORK, represent the orthogonal
C             matrix Q as a product of min(M,N) elementary reflectors
C             (see METHOD);
C             the elements of the subarray A(1:RANK,RANK+1:N), with the
C             next RANK entries of the array DWORK, represent the
C             orthogonal matrix Z as a product of RANK elementary
C             reflectors (see METHOD).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,NRHS)
C             On entry, the leading M-by-NRHS part of this array must
C             contain the right hand side matrix B.
C             On exit, the leading N-by-NRHS part of this array contains
C             the solution matrix X.
C             If M >= N and RANK = N, the residual sum-of-squares for
C             the solution in the i-th column is given by the sum of
C             squares of elements N+1:M in that column.
C             If NRHS = 0, this array is not referenced, and the routine
C             returns the effective rank of A, and its QR factorization.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,M,N).
C
C     Y       (input) DOUBLE PRECISION array, dimension ( N*NRHS )
C             If JOB = 'F', the elements Y(1:(N-RANK)*NRHS) are used as
C             free elements in computing the solution (see METHOD).
C             The remaining elements are not referenced.
C             If JOB = 'L', or NRHS = 0, this array is not referenced.
C
C     JPVT    (input/output) INTEGER array, dimension (N)
C             On entry with INIPER = 'P', if JPVT(i) <> 0, the i-th
C             column of A is an initial column, otherwise it is a free
C             column.  Before the QR factorization of A, all initial
C             columns are permuted to the leading positions; only the
C             remaining free columns are moved as a result of column
C             pivoting during the factorization.
C             If INIPER = 'N', JPVT need not be set on entry.
C             On exit, if JPVT(i) = k, then the i-th column of A*P
C             was the k-th column of A.
C
C     RANK    (output) INTEGER
C             The effective rank of A, i.e., the order of the submatrix
C             R11.  This is the same as the order of the submatrix T11
C             in the complete orthogonal factorization of A.
C
C     SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
C             The estimates of some of the singular values of the
C             triangular factor R11:
C             SVAL(1): largest singular value of  R(1:RANK,1:RANK);
C             SVAL(2): smallest singular value of R(1:RANK,1:RANK);
C             SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1),
C                      if RANK < MIN( M, N ), or of R(1:RANK,1:RANK),
C                      otherwise.
C             If the triangular factorization is a rank-revealing one
C             (which will be the case if the leading columns were well-
C             conditioned), then SVAL(1) will also be an estimate for
C             the largest singular value of A, and SVAL(2) and SVAL(3)
C             will be estimates for the RANK-th and (RANK+1)-st singular
C             values of A, respectively.
C             By examining these values, one can confirm that the rank
C             is well defined with respect to the chosen value of RCOND.
C             The ratio SVAL(1)/SVAL(2) is an estimate of the condition
C             number of R(1:RANK,1:RANK).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension LDWORK
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, and the entries 2 to min(M,N) + RANK + 1
C             contain the scalar factors of the elementary reflectors
C             used in the complete orthogonal factorization of A.
C             Among the entries 2 to min(M,N) + 1, only the first RANK
C             elements are useful, if INIPER = 'N'.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= max( min(M,N)+3*N+1, 2*min(M,N)+NRHS )
C             For optimum performance LDWORK should be larger.
C
C     Error indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     If INIPER = 'P', the routine first computes a QR factorization
C     with column pivoting:
C         A * P = Q * [ R11 R12 ]
C                     [  0  R22 ]
C     with R11 defined as the largest leading submatrix whose estimated
C     condition number is less than 1/RCOND.  The order of R11, RANK,
C     is the effective rank of A.
C     If INIPER = 'N', the effective rank is estimated during a
C     truncated QR factorization (with column pivoting) process, and
C     the submatrix R22 is not upper triangular, but full and of small
C     norm. (See SLICOT Library routines MB03OD or MB03OY, respectively,
C     for further details.)
C
C     Then, R22 is considered to be negligible, and R12 is annihilated
C     by orthogonal transformations from the right, arriving at the
C     complete orthogonal factorization:
C        A * P = Q * [ T11 0 ] * Z
C                    [  0  0 ]
C     The solution is then
C        X = P * Z' [ inv(T11)*Q1'*B ]
C                   [        Y       ]
C     where Q1 consists of the first RANK columns of Q, and Y contains
C     free elements (if JOB = 'F'), or is zero (if JOB = 'L').
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     FURTHER COMMENTS
C
C     Significant gain in efficiency is possible for small-rank problems
C     using truncated QR factorization (option INIPER = 'N').
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, Technical University of Sofia, Oct. 1998,
C     modification of the LAPACK routine DGELSX.
C     V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library
C     version.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005.
C
C     KEYWORDS
C
C     Least squares problems, QR factorization.
C
C     ******************************************************************
C
      DOUBLE PRECISION   ZERO, ONE, DONE, NTDONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO,
     $                     NTDONE = ONE )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          INIPER, JOB
      INTEGER            INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     ..
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   SVAL( 3 ), Y ( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            LEASTS, PERMUT
      INTEGER            I, IASCL, IBSCL, J, K, MAXWRK, MINWRK, MN
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMLNUM, T1, T2
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLABAD, DLACPY, DLASCL, DLASET, DORMQR, DORMRZ,
     $                   DTRSM, DTZRZF, MB03OD, MB03OY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      MN = MIN( M, N )
      LEASTS = LSAME( JOB, 'L' )
      PERMUT = LSAME( INIPER, 'P' )
C
C     Test the input scalar arguments.
C
      INFO   = 0
      MINWRK = MAX( MN + 3*N + 1, 2*MN + NRHS )
      IF( .NOT. ( LEASTS .OR. LSAME( JOB, 'F' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( PERMUT .OR. LSAME( INIPER, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN
         INFO = -6
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -11
      ELSE IF( LDWORK.LT.MINWRK ) THEN
         INFO = -17
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02QD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MN.EQ.0 ) THEN
         RANK = 0
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Get machine parameters.
C
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
C
C     Scale A, B if max entries outside range [SMLNUM,BIGNUM].
C
      ANRM = DLANGE( 'M', M, N, A, LDA, DWORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
C
C        Scale matrix norm up to SMLNUM.
C
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
C
C        Scale matrix norm down to BIGNUM.
C
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
C
C        Matrix all zero. Return zero solution.
C
         IF( NRHS.GT.0 )
     $      CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         RANK = 0
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      IF( NRHS.GT.0 ) THEN
         BNRM = DLANGE( 'M', M, NRHS, B, LDB, DWORK )
         IBSCL = 0
         IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
C
C           Scale matrix norm up to SMLNUM.
C
            CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB,
     $                   INFO )
            IBSCL = 1
         ELSE IF( BNRM.GT.BIGNUM ) THEN
C
C           Scale matrix norm down to BIGNUM.
C
            CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB,
     $                   INFO )
            IBSCL = 2
         END IF
      END IF
C
C     Compute a rank-revealing QR factorization of A and estimate its
C     effective rank using incremental condition estimation:
C        A * P = Q * R.
C     Workspace need   min(M,N)+3*N+1;
C               prefer min(M,N)+2*N+N*NB.
C     Details of Householder transformations stored in DWORK(1:MN).
C     (Note: Comments in the code beginning "Workspace:" describe the
C      minimal amount of workspace needed at that point in the code,
C      as well as the preferred amount for good performance.
C      NB refers to the optimal block size for the immediately
C      following subroutine, as returned by ILAENV.)
C
      MAXWRK = MINWRK
      IF( PERMUT ) THEN
         CALL MB03OD( 'Q', M, N, A, LDA, JPVT, RCOND, SVLMAX,
     $                DWORK( 1 ), RANK, SVAL, DWORK( MN+1 ), LDWORK-MN,
     $                INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( MN+1 ) ) + MN )
      ELSE
         CALL MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                DWORK( 1 ), DWORK( MN+1 ), INFO )
      END IF
C
C     Logically partition R = [ R11 R12 ]
C                             [  0  R22 ],
C     where R11 = R(1:RANK,1:RANK).
C
C     [R11,R12] = [ T11, 0 ] * Z.
C
C     Details of Householder transformations stored in DWORK(MN+1:2*MN).
C     Workspace need   3*min(M,N);
C               prefer 2*min(M,N)+min(M,N)*NB.
C
      IF( RANK.LT.N ) THEN
         CALL DTZRZF( RANK, N, A, LDA, DWORK( MN+1 ), DWORK( 2*MN+1 ),
     $                LDWORK-2*MN, INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN )
      END IF
C
      IF( NRHS.GT.0 ) THEN
C
C        B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS).
C
C        Workspace: need   2*min(M,N)+NRHS;
C                   prefer   min(M,N)+NRHS*NB.
C
         CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA,
     $                DWORK( 1 ), B, LDB, DWORK( 2*MN+1 ), LDWORK-2*MN,
     $                INFO )
         MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN )
C
C        B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS).
C
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
     $               NRHS, ONE, A, LDA, B, LDB )
C
         IF( RANK.LT.N ) THEN
C
C           Set B(RANK+1:N,1:NRHS).
C
            IF( LEASTS ) THEN
               CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO,
     $                      B(RANK+1,1), LDB )
            ELSE
               CALL DLACPY( 'Full', N-RANK, NRHS, Y, N-RANK,
     $                      B(RANK+1,1), LDB )
            END IF
C
C           B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS).
C
C           Workspace need   2*min(M,N)+NRHS;
C                     prefer 2*min(M,N)+NRHS*NB.
C
            CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
     $                   LDA, DWORK( MN+1 ), B, LDB, DWORK( 2*MN+1 ),
     $                   LDWORK-2*MN, INFO )
            MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN )
         END IF
C
C        Additional workspace: NRHS.
C
C        B(1:N,1:NRHS) := P * B(1:N,1:NRHS).
C
         DO 50 J = 1, NRHS
            DO 20 I = 1, N
               DWORK( 2*MN+I ) = NTDONE
   20       CONTINUE
            DO 40 I = 1, N
               IF( DWORK( 2*MN+I ).EQ.NTDONE ) THEN
                  IF( JPVT( I ).NE.I ) THEN
                     K  = I
                     T1 = B( K, J )
                     T2 = B( JPVT( K ), J )
   30                CONTINUE
                     B( JPVT( K ), J ) = T1
                     DWORK( 2*MN+K ) = DONE
                     T1 = T2
                     K  = JPVT( K )
                     T2 = B( JPVT( K ), J )
                     IF( JPVT( K ).NE.I )
     $                  GO TO 30
                     B( I, J ) = T1
                     DWORK( 2*MN+K ) = DONE
                  END IF
               END IF
   40       CONTINUE
   50    CONTINUE
C
C        Undo scaling for B.
C
         IF( IBSCL.EQ.1 ) THEN
            CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB,
     $                   INFO )
         ELSE IF( IBSCL.EQ.2 ) THEN
            CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB,
     $                   INFO )
         END IF
      END IF
C
C     Undo scaling for A.
C
      IF( IASCL.EQ.1 ) THEN
         IF( NRHS.GT.0 )
     $      CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB,
     $                   INFO )
         CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
     $                INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         IF( NRHS.GT.0 )
     $      CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB,
     $                   INFO )
         CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
     $                INFO )
      END IF
C
      DO 60 I = MN + RANK, 1, -1
         DWORK( I+1 ) = DWORK( I )
   60 CONTINUE
C
      DWORK( 1 ) = MAXWRK
      RETURN
C *** Last line of MB02QD ***
      END


C
C**************************  FVGDKR ************************************
C
C  calculate derivative of relative hydraulic conductivity with respect
C  to pressure head using van Genuchten characteristic equation.
C  We use the same calculation as for the extended van Genuchten
C  curves (i.e. the derivative is formulated in terms of PSI rather than
C  in terms of SE and DSEDP) in order to avoid division by zero.
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FVGDKR(PSI,INOD)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      INTEGER  INOD
      REAL*8   BETA,B1,V1,V2,V3,V4
      REAL*8   PSI
      INCLUDE 'SOILCHAR.H'
C
      IF (PSI .LT. -1.0D-14) THEN
         BETA=(ABS(PSI/VGPSAT(INOD)))**VGN(INOD)
         B1=BETA+1.0D0
         V1=ABS(B1)**VGM(INOD) - ABS(BETA)**VGM(INOD)
         V2=VGPSAT(INOD)/PSI
         V3=VGN1(INOD)*BETA*V2*(ABS(1.0D0/B1)**VGM52(INOD))/VGPSAT(INOD)
         V4=V2*((2.5D0/B1)*BETA - 2.0D0) - 0.5D0*(ABS(B1)**VGMM1(INOD))
         FVGDKR=V3*V1*V4
      ELSE
         FVGDKR=0.0D0
      END IF
C
      RETURN
      END


      subroutine imppol(ndata,x,y,a)
c
c     + + + PURPOSE + + +
c
c     SR IMPPOL is an impoundment element subroutine used to
c     develop polynomial fit coefficients for a 4th degree
c     polynomial.   It is based upon the "Numerical Recipes
c     in Fortran" SR SVDFIT.
c
c     Called from: IMPINT
c
c     Copyright (C) 1986, 1992 Numerical Recipes Software
c
c     Permission is granted for use only within USDA Water Erosion
c     Prediction Project code
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      integer ndata
      real x(100), y(100), a(5)
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     a(i)  - the fit coefficients returned to SR IMPINT
c     ndata - # of points to be fitted
c     x(i)  - stage values from SR IMPINT
c     y(i)  - discharge values from SR IMPINT
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      integer ma, mp, np, i, j, jf
      real chisq, u(100,5), v(5,5), w(5), tol, sum, thresh, wmax,
     1    afunc(5), b(100)
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Variable definitions (note:  this is a canned subroutine
c     only the varibles entering and exiting are defined)
c
c     afunc(i) - the transformed x values
c     ma       - number of x values in the function (5)
c     mp       - number of pairs of points included in the regression
c     np       - set to ma
c     u(i,j)   - transformed matrix of x values
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     impsvb
c     impsvd
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      ma = 5
      mp = ndata
      np = ma
      tol = 1.e-5
c
c     defining afunc and u
c
      do 30 i = 1, ndata
        afunc(1) = 1.0
c
        do 10 jf = 2, 5
          afunc(jf) = afunc(jf-1) * x(i)
   10   continue
c
        do 20 j = 1, ma
          u(i,j) = afunc(j)
   20   continue
c
        b(i) = y(i)
   30 continue
c
      call impsvd(u,ndata,ma,w,v)
c
      wmax = 0.0
c
      do 40 j = 1, ma
        if (w(j).gt.wmax) wmax = w(j)
   40 continue
c
      thresh = tol * wmax
c
      do 50 j = 1, ma
        if (w(j).lt.thresh) w(j) = 0.
   50 continue
c
      call impsvb(u,w,v,ndata,ma,b,a)
c
      chisq = 0.0
c
      do 80 i = 1, ndata
        afunc(1) = 1.0
c
        do 60 jf = 2, 5
          afunc(jf) = afunc(jf-1) * x(i)
   60   continue
c
        sum = 0.0
c
        do 70 j = 1, ma
          sum = sum + a(j) * afunc(j)
   70   continue
c
        chisq = chisq + (y(i)-sum) ** 2
   80 continue
c
      return
      end


!*==zggsvd3.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGGSVD3 computes the singular value decomposition (SVD) for OTHER matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGGSVD3 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
!                           LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK,
!                           LWORK, RWORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBQ, JOBU, JOBV
!       INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P, LWORK
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       DOUBLE PRECISION   ALPHA( * ), BETA( * ), RWORK( * )
!       COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
!      $                   U( LDU, * ), V( LDV, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGGSVD3 computes the generalized singular value decomposition (GSVD)
!> of an M-by-N complex matrix A and P-by-N complex matrix B:
!>
!>       U**H*A*Q = D1*( 0 R ),    V**H*B*Q = D2*( 0 R )
!>
!> where U, V and Q are unitary matrices.
!> Let K+L = the effective numerical rank of the
!> matrix (A**H,B**H)**H, then R is a (K+L)-by-(K+L) nonsingular upper
!> triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal"
!> matrices and of the following structures, respectively:
!>
!> If M-K-L >= 0,
!>
!>                     K  L
!>        D1 =     K ( I  0 )
!>                 L ( 0  C )
!>             M-K-L ( 0  0 )
!>
!>                   K  L
!>        D2 =   L ( 0  S )
!>             P-L ( 0  0 )
!>
!>                 N-K-L  K    L
!>   ( 0 R ) = K (  0   R11  R12 )
!>             L (  0    0   R22 )
!> where
!>
!>   C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
!>   S = diag( BETA(K+1),  ... , BETA(K+L) ),
!>   C**2 + S**2 = I.
!>
!>   R is stored in A(1:K+L,N-K-L+1:N) on exit.
!>
!> If M-K-L < 0,
!>
!>                   K M-K K+L-M
!>        D1 =   K ( I  0    0   )
!>             M-K ( 0  C    0   )
!>
!>                     K M-K K+L-M
!>        D2 =   M-K ( 0  S    0  )
!>             K+L-M ( 0  0    I  )
!>               P-L ( 0  0    0  )
!>
!>                    N-K-L  K   M-K  K+L-M
!>   ( 0 R ) =     K ( 0    R11  R12  R13  )
!>               M-K ( 0     0   R22  R23  )
!>             K+L-M ( 0     0    0   R33  )
!>
!> where
!>
!>   C = diag( ALPHA(K+1), ... , ALPHA(M) ),
!>   S = diag( BETA(K+1),  ... , BETA(M) ),
!>   C**2 + S**2 = I.
!>
!>   (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
!>   ( 0  R22 R23 )
!>   in B(M-K+1:L,N+M-K-L+1:N) on exit.
!>
!> The routine computes C, S, R, and optionally the unitary
!> transformation matrices U, V and Q.
!>
!> In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
!> A and B implicitly gives the SVD of A*inv(B):
!>                      A*inv(B) = U*(D1*inv(D2))*V**H.
!> If ( A**H,B**H)**H has orthonormal columns, then the GSVD of A and B is also
!> equal to the CS decomposition of A and B. Furthermore, the GSVD can
!> be used to derive the solution of the eigenvalue problem:
!>                      A**H*A x = lambda* B**H*B x.
!> In some literature, the GSVD of A and B is presented in the form
!>                  U**H*A*X = ( 0 D1 ),   V**H*B*X = ( 0 D2 )
!> where U and V are orthogonal and X is nonsingular, and D1 and D2 are
!> ``diagonal''.  The former GSVD form can be converted to the latter
!> form by taking the nonsingular matrix X as
!>
!>                       X = Q*(  I   0    )
!>                             (  0 inv(R) )
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBU
!> \verbatim
!>          JOBU is CHARACTER*1
!>          = 'U':  Unitary matrix U is computed;
!>          = 'N':  U is not computed.
!> \endverbatim
!>
!> \param[in] JOBV
!> \verbatim
!>          JOBV is CHARACTER*1
!>          = 'V':  Unitary matrix V is computed;
!>          = 'N':  V is not computed.
!> \endverbatim
!>
!> \param[in] JOBQ
!> \verbatim
!>          JOBQ is CHARACTER*1
!>          = 'Q':  Unitary matrix Q is computed;
!>          = 'N':  Q is not computed.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrices A and B.  N >= 0.
!> \endverbatim
!>
!> \param[in] P
!> \verbatim
!>          P is INTEGER
!>          The number of rows of the matrix B.  P >= 0.
!> \endverbatim
!>
!> \param[out] K
!> \verbatim
!>          K is INTEGER
!> \endverbatim
!>
!> \param[out] L
!> \verbatim
!>          L is INTEGER
!>
!>          On exit, K and L specify the dimension of the subblocks
!>          described in Purpose.
!>          K + L = effective numerical rank of (A**H,B**H)**H.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, A contains the triangular matrix R, or part of R.
!>          See Purpose for details.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension (LDB,N)
!>          On entry, the P-by-N matrix B.
!>          On exit, B contains part of the triangular matrix R if
!>          M-K-L < 0.  See Purpose for details.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,P).
!> \endverbatim
!>
!> \param[out] ALPHA
!> \verbatim
!>          ALPHA is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[out] BETA
!> \verbatim
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>
!>          On exit, ALPHA and BETA contain the generalized singular
!>          value pairs of A and B;
!>            ALPHA(1:K) = 1,
!>            BETA(1:K)  = 0,
!>          and if M-K-L >= 0,
!>            ALPHA(K+1:K+L) = C,
!>            BETA(K+1:K+L)  = S,
!>          or if M-K-L < 0,
!>            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
!>            BETA(K+1:M) =S, BETA(M+1:K+L) =1
!>          and
!>            ALPHA(K+L+1:N) = 0
!>            BETA(K+L+1:N)  = 0
!> \endverbatim
!>
!> \param[out] U
!> \verbatim
!>          U is COMPLEX*16 array, dimension (LDU,M)
!>          If JOBU = 'U', U contains the M-by-M unitary matrix U.
!>          If JOBU = 'N', U is not referenced.
!> \endverbatim
!>
!> \param[in] LDU
!> \verbatim
!>          LDU is INTEGER
!>          The leading dimension of the array U. LDU >= max(1,M) if
!>          JOBU = 'U'; LDU >= 1 otherwise.
!> \endverbatim
!>
!> \param[out] V
!> \verbatim
!>          V is COMPLEX*16 array, dimension (LDV,P)
!>          If JOBV = 'V', V contains the P-by-P unitary matrix V.
!>          If JOBV = 'N', V is not referenced.
!> \endverbatim
!>
!> \param[in] LDV
!> \verbatim
!>          LDV is INTEGER
!>          The leading dimension of the array V. LDV >= max(1,P) if
!>          JOBV = 'V'; LDV >= 1 otherwise.
!> \endverbatim
!>
!> \param[out] Q
!> \verbatim
!>          Q is COMPLEX*16 array, dimension (LDQ,N)
!>          If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.
!>          If JOBQ = 'N', Q is not referenced.
!> \endverbatim
!>
!> \param[in] LDQ
!> \verbatim
!>          LDQ is INTEGER
!>          The leading dimension of the array Q. LDQ >= max(1,N) if
!>          JOBQ = 'Q'; LDQ >= 1 otherwise.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (N)
!>          On exit, IWORK stores the sorting information. More
!>          precisely, the following loop will sort ALPHA
!>             for I = K+1, min(M,K+L)
!>                 swap ALPHA(I) and ALPHA(IWORK(I))
!>             endfor
!>          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = 1, the Jacobi-type procedure failed to
!>                converge.  For further details, see subroutine ZTGSJA.
!> \endverbatim
!
!> \par Internal Parameters:
!  =========================
!>
!> \verbatim
!>  TOLA    DOUBLE PRECISION
!>  TOLB    DOUBLE PRECISION
!>          TOLA and TOLB are the thresholds to determine the effective
!>          rank of (A**H,B**H)**H. Generally, they are set to
!>                   TOLA = MAX(M,N)*norm(A)*MACHEPS,
!>                   TOLB = MAX(P,N)*norm(B)*MACHEPS.
!>          The size of TOLA and TOLB may affect the size of backward
!>          errors of the decomposition.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date August 2015
!
!> \ingroup complex16GEsing
!
!> \par Contributors:
!  ==================
!>
!>     Ming Gu and Huan Ren, Computer Science Division, University of
!>     California at Berkeley, USA
!>
!
!> \par Further Details:
!  =====================
!>
!>  ZGGSVD3 replaces the deprecated subroutine ZGGSVD.
!>
!  =====================================================================
      SUBROUTINE ZGGSVD3(Jobu,Jobv,Jobq,M,N,P,K,L,A,Lda,B,Ldb,Alpha,    &
     &                   Beta,U,Ldu,V,Ldv,Q,Ldq,Work,Lwork,Rwork,Iwork, &
     &                   Info)
      IMPLICIT NONE
!*--ZGGSVD3357
!
!  -- LAPACK driver 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..--
!     August 2015
!
!     .. Scalar Arguments ..
      CHARACTER Jobq , Jobu , Jobv
      INTEGER Info , K , L , Lda , Ldb , Ldq , Ldu , Ldv , M , N , P ,  &
     &        Lwork
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      DOUBLE PRECISION Alpha(*) , Beta(*) , Rwork(*)
      COMPLEX*16 A(Lda,*) , B(Ldb,*) , Q(Ldq,*) , U(Ldu,*) , V(Ldv,*) , &
     &           Work(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL wantq , wantu , wantv , lquery
      INTEGER i , ibnd , isub , j , ncycle , lwkopt
      DOUBLE PRECISION anorm , bnorm , smax , temp , tola , tolb , ulp ,&
     &                 unfl
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      DOUBLE PRECISION DLAMCH , ZLANGE
      EXTERNAL LSAME , DLAMCH , ZLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL DCOPY , XERBLA , ZGGSVP3 , ZTGSJA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      wantu = LSAME(Jobu,'U')
      wantv = LSAME(Jobv,'V')
      wantq = LSAME(Jobq,'Q')
      lquery = (Lwork==-1)
      lwkopt = 1
!
!     Test the input arguments
!
      Info = 0
      IF ( .NOT.(wantu .OR. LSAME(Jobu,'N')) ) THEN
         Info = -1
      ELSEIF ( .NOT.(wantv .OR. LSAME(Jobv,'N')) ) THEN
         Info = -2
      ELSEIF ( .NOT.(wantq .OR. LSAME(Jobq,'N')) ) THEN
         Info = -3
      ELSEIF ( M<0 ) THEN
         Info = -4
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( P<0 ) THEN
         Info = -6
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -10
      ELSEIF ( Ldb<MAX(1,P) ) THEN
         Info = -12
      ELSEIF ( Ldu<1 .OR. (wantu .AND. Ldu<M) ) THEN
         Info = -16
      ELSEIF ( Ldv<1 .OR. (wantv .AND. Ldv<P) ) THEN
         Info = -18
      ELSEIF ( Ldq<1 .OR. (wantq .AND. Ldq<N) ) THEN
         Info = -20
      ELSEIF ( Lwork<1 .AND. .NOT.lquery ) THEN
         Info = -24
      ENDIF
!
!     Compute workspace
!
      IF ( Info==0 ) THEN
         CALL ZGGSVP3(Jobu,Jobv,Jobq,M,P,N,A,Lda,B,Ldb,tola,tolb,K,L,U, &
     &                Ldu,V,Ldv,Q,Ldq,Iwork,Rwork,Work,Work,-1,Info)
         lwkopt = N + INT(Work(1))
         lwkopt = MAX(2*N,lwkopt)
         lwkopt = MAX(1,lwkopt)
         Work(1) = DCMPLX(lwkopt)
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGGSVD3',-Info)
         RETURN
      ENDIF
      IF ( lquery ) RETURN
!
!     Compute the Frobenius norm of matrices A and B
!
      anorm = ZLANGE('1',M,N,A,Lda,Rwork)
      bnorm = ZLANGE('1',P,N,B,Ldb,Rwork)
!
!     Get machine precision and set up threshold for determining
!     the effective numerical rank of the matrices A and B.
!
      ulp = DLAMCH('Precision')
      unfl = DLAMCH('Safe Minimum')
      tola = MAX(M,N)*MAX(anorm,unfl)*ulp
      tolb = MAX(P,N)*MAX(bnorm,unfl)*ulp
!
      CALL ZGGSVP3(Jobu,Jobv,Jobq,M,P,N,A,Lda,B,Ldb,tola,tolb,K,L,U,Ldu,&
     &             V,Ldv,Q,Ldq,Iwork,Rwork,Work,Work(N+1),Lwork-N,Info)
!
!     Compute the GSVD of two upper "triangular" matrices
!
      CALL ZTGSJA(Jobu,Jobv,Jobq,M,P,N,K,L,A,Lda,B,Ldb,tola,tolb,Alpha, &
     &            Beta,U,Ldu,V,Ldv,Q,Ldq,Work,ncycle,Info)
!
!     Sort the singular values and store the pivot indices in IWORK
!     Copy ALPHA to RWORK, then sort ALPHA in RWORK
!
      CALL DCOPY(N,Alpha,1,Rwork,1)
      ibnd = MIN(L,M-K)
      DO i = 1 , ibnd
!
!        Scan for largest ALPHA(K+I)
!
         isub = i
         smax = Rwork(K+i)
         DO j = i + 1 , ibnd
            temp = Rwork(K+j)
            IF ( temp>smax ) THEN
               isub = j
               smax = temp
            ENDIF
         ENDDO
         IF ( isub/=i ) THEN
            Rwork(K+isub) = Rwork(K+i)
            Rwork(K+i) = smax
            Iwork(K+i) = K + isub
         ELSE
            Iwork(K+i) = K + i
         ENDIF
      ENDDO
!
      Work(1) = DCMPLX(lwkopt)
!
!     End of ZGGSVD3
!
      END SUBROUTINE ZGGSVD3


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine quadmeshquality(netet_,cotet,kontet,iedtet,
     &     iedgmid,qualityjac,ielem)
!
!     calculate the element quality. At first the jacobian in all 4
!     integration points of the 10-node tet are calculated. If the minimum
!     value is negative the quality is set to a very big number. If not,
!     the quality is the difference of the extremes divided by the sum
!     of the extremes. This quality measure is good if the vertex nodes
!     of the tetrahedron are fixed.
!
!     if ielem>0 the quality for this element is calculated, if
!     ielem=0 the quality for all elements in the mesh is determined
!
      implicit none
!
      integer netet_,iedtet(6,*),kontet(4,*),k,iedgmid(*),i,j,iflag,
     &     ielem
!
      real*8 cotet(3,*),qualityjac(*),xjac(4),xsj,xi,et,ze,xl(3,10),
     &     shp(4,10),maxjac,minjac
!
      include "gauss.f"
!
      iflag=2
!
      if(ielem.eq.0) then
!
!     calculating the quality for all elements
!
        do i=1,netet_
          if(kontet(1,i).eq.0) cycle
!
!     coordinates of the vertex nodes
!
          do j=1,4
            do k=1,3
              xl(k,j)=cotet(k,kontet(j,i))
            enddo
          enddo
!
!     coordinates of the midnodes
!
          do j=1,6
            do k=1,3
              xl(k,j+4)=cotet(k,iedgmid(iedtet(j,i)))
            enddo
          enddo
!
!     determine the jacobian at the four integration points
!
          do j=1,4
            xi=gauss3d5(1,j)
            et=gauss3d5(2,j)
            ze=gauss3d5(3,j)
            call shape10tet(xi,et,ze,xl,xsj,shp,iflag)
            xjac(j)=xsj
          enddo
!
!     find the maximum and minimum jacobian
!
          maxjac=max(xjac(1),xjac(2),xjac(3),xjac(4))
          minjac=min(xjac(1),xjac(2),xjac(3),xjac(4))
!
!     calculate the quality
!
          if(minjac.le.0.d0) then
            qualityjac(i)=1.d10-1.d10*minjac
          else
            qualityjac(i)=(maxjac-minjac)/(maxjac+minjac)
          endif
        enddo
      else
!
!     calculating the quality for just one element
!
        i=ielem
!
!     coordinates of the vertex nodes
!
        do j=1,4
          do k=1,3
            xl(k,j)=cotet(k,kontet(j,i))
          enddo
        enddo
!
!     coordinates of the midnodes
!
        do j=1,6
          do k=1,3
            xl(k,j+4)=cotet(k,iedgmid(iedtet(j,i)))
          enddo
        enddo
!
!     determine the jacobian at the four integration points
!
        do j=1,4
          xi=gauss3d5(1,j)
          et=gauss3d5(2,j)
          ze=gauss3d5(3,j)
          call shape10tet(xi,et,ze,xl,xsj,shp,iflag)
          xjac(j)=xsj
        enddo
!
!     find the maximum and minimum jacobian
!
        maxjac=max(xjac(1),xjac(2),xjac(3),xjac(4))
        minjac=min(xjac(1),xjac(2),xjac(3),xjac(4))
!
!     calculate the quality
!
        if(minjac.le.0.d0) then
          qualityjac(i)=1.d10-1.d10*minjac
        else
          qualityjac(i)=(maxjac-minjac)/(maxjac+minjac)
        endif
      endif
!
      return
      end


      subroutine cartrotx(a, vin, vout)
c
c  Cart. Coord System  Rotation about X Axis
c  ------------------------------------------------------------------------
c  Part of "poa_calfos" (STECF/IPMG)
c
c  History:
c  --------
c  Version   Date        Author          Description
c      1.0       Jul 00  M. Rosa         POA calibration code
c  ------------------------------------------------------------------------
c
      real*8  a, ac, as, vin(3), vout(3)
      DOUBLE PRECISION  DGTORD, PI
      DATA PI /3.14159265358979323846D+00/
      DGTORD = PI / 180.0D0

      ac = dcos(DGTORD*a)
      as = dsin(DGTORD*a)
      vout(1) = vin(1)
      vout(2) = vin(2)*ac - vin(3)*as
      vout(3) = vin(2)*as + vin(3)*ac
      return
      end


c     # This routine rotates cell-centered data into frame specified
c     # by vectors at the edge.  The flux is then computed from this
c     # rotated data.
c     #
c     # All scaling and potential sign changes are handled by the
c     # calling routine.
c
c     # Note that edge tangents must be normalized.

      subroutine  rpn2_cons_update_manifold(meqn,maux, idir, iface, q,
     &                                     auxvec_center,
     &                                     auxvec_edge,flux)
      implicit none

      integer meqn,maux,idir, iface
      double precision q(meqn), flux(meqn)
      double precision auxvec_center(maux), auxvec_edge(maux)

      double precision grav
      common /cparam/  grav

      double precision enx, eny, enz
      double precision etx, ety, etz
      double precision hun, hut, h, un, ut, gamma, f(4)
      integer ioff

c     #  f1 = (hu; hu^2 + 0.5*g*h^2; huv)
c     #  f2 = (hv; huv; hv^2 + 0.5*gh^2)

      if (idir .eq. 0) then
          ioff = 1
      else
          ioff = 7
      endif

      enx =   auxvec_edge(ioff+1)
      eny =   auxvec_edge(ioff+2)
      enz =   auxvec_edge(ioff+3)
      etx =   auxvec_edge(ioff+4)
      ety =   auxvec_edge(ioff+5)
      etz =   auxvec_edge(ioff+6)

c     !! Normalize the edge lengths
      gamma = dsqrt(etx**2 + ety**2 + etz**2)
      etx =   etx / gamma
      ety =   ety / gamma
      etz =   etz / gamma

      hun = enx*q(2)   + eny*q(3)   + enz*q(4)
      hut = etx*q(2)   + ety*q(3)   + etz*q(4)

      h = q(1)
      un = hun/h
      ut = hut/h

      f(1) = hun
      f(2) = hun**2/h + 0.5*grav*h**2
      f(3) = un*hut
      f(4)  = un*q(4)

      flux(1) = hun
      flux(2) = enx*f(2) + etx*f(3)
      flux(3) = eny*f(2) + ety*f(3)
      flux(4) = enz*f(2) + etz*f(3)

      end


FUNCTION dawn(dlat,dlong,idoy,riseangle)
!
IMPLICIT NONE
!
! Function arguments
!
REAL :: dlat,dlong,riseangle
INTEGER :: idoy
REAL :: dawn
!
! Local variables
!
REAL :: dec,e,h,sn
REAL :: declination,equa_time,hourangle
!
!     + + + purpose + + +
!     this function calculates the time of sunrise (hours) for any simulation
!     site based on the global position of the site, and day of the
!     year.  the inputs for the function are day of the year, latitude
!     of the site, and longitude of the site.

!     + + + keywords + + +
!     sunrise

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     idoy   - day of year
!     dlat   - latitude of the site, degrees (north > 0, south < 0)
!     dlong  - longitude of the site, degrees (east > 0, west < 0)
!     riseangle - angle of earths rotation where sunrise occurs
!                 this varies depending on whether you are calculating
!                 direct beam, civil twilight, nautical twilight or
!                 astronomical twilight hourangle

!     + + + local variables + + +

!     + + + local definitions + + +
!     dec    - declination of earth with respect to the sun (degrees)
!     e      - equation of time (minutes)
!     h      - hour angle (degrees)
!     sn     - solar noon (hour of the day, midnight = 0.0)

!     + + + common blocks + + +

!     include 'p1const.inc'
!     include 'p1unconv.inc'

!     + + + function declarations + + +

!     + + + end specifications + + +

!     declination angle (dec)
dec = declination(idoy)

!     sunset hour angle (noon is zero degrees, sunset (+), sunrise (-))
h = hourangle(dlat,dec,riseangle)

!     equation of time (e)
e = equa_time(idoy)

!     calculate solar noon (sn)
sn = 12.0 - e/60.0 - 4.0*mod(dlong,15.0)/60.0

!     calculate the time of sunrise (rise)
dawn = sn - h/15.0

!     to prevent errors of bleed over into previous day where
!     where daylength is 24 hours, limit time of sunrise
dawn = max(0.0,dawn)
!
END FUNCTION dawn

Project Documents/Source Code Original/Dawn.f90


SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my,xlower,ylower,dx,dy,q,maux,aux)
  IMPLICIT NONE

  INTEGER meqn, mbc, mx, my, maux
  DOUBLE PRECISION xlower, ylower, dx, dy
  INTEGER*8 cont, get_context
  INTEGER blockno, fc2d_clawpack5_get_block
  DOUBLE PRECISION q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
  DOUBLE PRECISION aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

  INTEGER i,j
  DOUBLE PRECISION xc,yc,xp,yp,zp
  DOUBLE PRECISION cosine_bell_sum

  DOUBLE PRECISION a,b

  cont = get_context()
  blockno = fc2d_clawpack5_get_block()

  a = -0.8d0
  b = 0.9d0

  DO j = 1-mbc,my+mbc
        yc = ylower + (j-0.5d0)*dy
     DO i = 1-mbc,mx+mbc
        xc = xlower + (i-0.5d0)*dx
        CALL fclaw2d_map_c2m(cont, &
             blockno,xc,yc,xp,yp,zp)
        q(1,i,j) = cosine_bell_sum(xp,yp,zp)
        IF (meqn .EQ. 2) THEN
           !! # Set non-linear relationship between two tracers
           q(2,i,j) = a*q(1,i,j)**2 + b
        ENDIF
     ENDDO
  ENDDO

  RETURN
END SUBROUTINE clawpack5_qinit


subroutine triad(a, b, scalar, c)
real, intent(in) :: a(:), b(:), scalar
real, intent(out) :: c(:)
integer :: N, N2, i, j
N = size(a)
N2 = size(b)
do concurrent (i = 1:N)
    c(i) = a(i) + scalar * b(i)
end do

do concurrent (j = 1:N2)
    c(j) = b(j) + scalar
end do
end subroutine


!ising_mpi_reduce.f90
program isingmodel_mpi
   implicit none
   include 'mpif.h'

   real :: kT, paccept,ptrial
   integer :: Estart,Eflip, iEtot,iEtotloc
   integer :: col, row, east,west,north,south
   integer :: nMC
   integer, parameter :: numL = 8 ! the number of row or column
   integer, parameter :: J = 1    ! define a ferromagnetic system
   integer, dimension(:,:), allocatable :: spin

        !mpi processes local index
   integer, parameter :: ni=numL, nj=numL
   integer :: ierr, myid, nprocs, i1, i2, j1, j2, i1p, i2m, j1p, j2m, &
              i1n, i2n, ninom, njnom, niproc, njproc, nitot
   integer :: status(mpi_status_size), row_type
   integer :: myparity,print_id
   integer,parameter :: H = 1, D = 0        ! tags of passing messages

     ! initialize MPI

   call mpi_init(ierr)
   call mpi_comm_rank(mpi_comm_world, myid, ierr)
   call mpi_comm_size(mpi_comm_world, nprocs, ierr)

   ! domain decomposition

  ! nominal number of points per proc., without ghost cells,
  ! assume numbers divide evenly; niproc and njproc are the
  ! numbers of procs in the i and j directions.
   niproc = nprocs
   njproc = 1
   ninom  = ni/niproc
   njnom  = nj/niproc

  ! nominal starting and ending indices, without ghost cells
   i1n = myid*ninom + 1
   i2n = i1n + ninom - 1

  ! local starting and ending index, including 2 ghost cells
  ! in each direction (at beginning and end)
   i1  = i1n - 1
   i1p = i1 + 1
   i2  = i2n + 1
   i2m = i2 - 1
   j1  = 0
   j1p = j1 + 1
   j2  = nj + 1
   j2m = j2 - 1
   nitot = i2 - i1 + 1

      ! allocate arrays
   allocate( spin(i1:i2,j1:j2) )

      ! random number generator
   call random_seed()

      ! initialize spin configuration
   do col=j1p,j2m
      do row=i1p,i2m
         call random_number(paccept)
         if (paccept .lt. 0.5) then
            spin(row,col) = +1
         else
            spin(row,col) = -1
         end if
      end do
   end do

   do print_id = 0,nprocs-1
      if(myid ==print_id) then
         write(*,*), 'initialized spin in Processor=',myid,'is'
         write(*,*), spin(i1p:i2m,j1p:j2m)
      endif
      call MPI_Barrier(MPI_COMM_WORLD,ierr)
   end do

  ! Create derived type for single row of array.
  ! There are nj "blocks," each containing 1 element,
  ! with a stride of nitot between the blocks

   call mpi_type_vector(nj+2, 1, nitot, mpi_integer, row_type, ierr);
   call mpi_type_commit(row_type, ierr);

    !  iterate
    !  messages passing divided in two steps depending on myid even or odd
   myparity = mod(myid,2)

   Temp_decreasing : do kT=4.0, 0.1, -0.05      !JS: Start at kT=4, and go to kT=0.1 in steps of -0.05

 !  transfor data to ghost cells via subroutine transfor_data

   call transfor_data(spin,i1,i1p,i2,i2m,j1,j1p,j2,j2m,row_type,nprocs,myid, &
        myparity,mpi_comm_world,ierr,status,H,D)

! loop MC trials
      MC_iteration: do nMC=1,1000

      do col=j1p,j2m
         do row=i1p,i2m

            east = col+1
            west = col-1
            north = row-1
            south = row+1

       ! try flip a spin at position (row,col)

       !call transfor_data(spin,i1,i1p,i2,i2m,j1,j1p,j2,j2m,row_type,nprocs,myid, &
       !     myparity,mpi_comm_world,ierr,status,H,D)

            Estart = -J*(spin(row,col)*spin(row,east) &
                 + spin(row,col)*spin(row,west) &
                 + spin(row,col)*spin(north,col) &
                 + spin(row,col)*spin(south,col) )

            Eflip =  -J*((-spin(row,col))*spin(row,east) &
                 + (-spin(row,col))*spin(row,west) &
                 + (-spin(row,col))*spin(north,col) &
                 + (-spin(row,col))*spin(south,col) )

      ! acceptance/rejectance for MC algorithm

            if (Eflip .lt. Estart) then
               spin(row,col) = -spin(row,col)
            else
               call random_number(paccept)
               ptrial = EXP(-(Eflip-Estart)/kT)

               if (paccept .lt. ptrial) then
                  spin(row,col) = -spin(row,col)
               end if
            end if

         end do
      end do

      enddo MC_iteration
   enddo Temp_decreasing
! calculate enery in each decomposition domain
! mpi_reduce to summerize the energy in master processor and print the results

   call sum_energy(spin,iEtot,i1,i1p,i2,i2m,j1,j1p,j2,j2m)

   if(myid==0) then
     write(*,*),"Temperature =", kT
     write(*,*),"the total energy at this Temperature =", iEtot
   endif

   do print_id = 0,nprocs-1
      if(myid ==print_id) then
         write(*,*), 'spin configurations in Processor=',myid,'is'
         write(*,*), spin(i1p:i2m,j1p:j2m)
      endif
      call MPI_Barrier(MPI_COMM_WORLD,ierr)
   end do
   deallocate(spin)

   call mpi_finalize(ierr)

contains

   subroutine sum_energy(spin,iEtot,i1,i1p,i2,i2m,j1,j1p,j2,j2m)
      integer,intent(in) :: i1,i1p,i2,i2m,j1,j1p,j2,j2m
      integer,intent(in), dimension(i1:i2,j1:j2) :: spin
      integer,intent(out) :: iEtot
      integer :: iEtot_loc
      integer :: east,west,north,south,col,row
      iEtot = 0
      do col=j1p,j2m
         do row=i1p,i2m

            east = col+1
            west = col-1
            north = row-1
            south = row+1

            iEtot = iEtot -J*(spin(row,col)*spin(row,east) &
                 + spin(row,col)*spin(row,west) &
                 + spin(row,col)*spin(north,col) &
                 + spin(row,col)*spin(south,col) )

         end do
      end do

      if(nprocs >1) then
        iEtot_loc = iEtot
        call mpi_reduce(iEtot_loc, iEtot, 1, mpi_integer, &
             mpi_sum, 0, mpi_comm_world, ierr)
      end if
   end subroutine sum_energy

subroutine transfor_data(spin,i1,i1p,i2,i2m,j1,j1p,j2,j2m,row_type,nprocs,myid, &
           myparity,mpi_comm_world,ierr,status,H,D)
   integer,intent(in) :: i1,i1p,i2,i2m,j1,j1p,j2,j2m
   integer,intent(in) :: row_type,nprocs,myid,myparity,mpi_comm_world, &
                         ierr,status(mpi_status_size)
   integer,parameter :: H=1, D=0
   integer,intent(inout), dimension(i1:i2,j1:j2) :: spin

        ! left and right boundary conditions
      spin(i1p:i2m,0)  = spin(i1p:i2m,j2m)
      spin(i1p:i2m,j2) = spin(i1p:i2m,1)

      if(nprocs == 1) then

        ! top and bottom boundary conditions

         spin(i1,:) = spin(i2m,:)
         spin(i2,:) = spin(i1p,:)

        ! corners

         spin(i1,j1) = spin(i2m,j2m)
         spin(i1,j2) = spin(i2m,j1p)
         spin(i2,j2) = spin(i1p,j1p)
         spin(i2,j1) = spin(i1p,j2m)

      elseif(myid == 0) then

        ! top and bottom boundary conditions

         call mpi_send(spin(i1p,j1), 1, row_type, &
              nprocs-1, D, mpi_comm_world, ierr)
         call mpi_recv(spin(i1,j1),  1, row_type, &
              nprocs-1, D, mpi_comm_world, status, ierr)
         call mpi_send(spin(i2m,j1), 1, row_type, &
              myid+1, H, mpi_comm_world, ierr)
         call mpi_recv(spin(i2,j1),  1, row_type, &
              myid+1, H, mpi_comm_world, status, ierr)

        ! corners

         call mpi_send(spin(i1p,j1p), 1, mpi_integer, &
              nprocs-1, 2, mpi_comm_world, ierr)
         call mpi_recv(spin(i1, j1 ), 1, mpi_integer, &
              nprocs-1, 3, mpi_comm_world, status, ierr)
         call mpi_send(spin(i1p,j2m), 1, mpi_integer, &
              nprocs-1, 4, mpi_comm_world, ierr)
         call mpi_recv(spin(i1, j2 ), 1, mpi_integer, &
              nprocs-1, 5, mpi_comm_world, status, ierr)
      elseif(myid < nprocs-1) then

        ! the processes in between (except P0 and the P-last ) only have top and bottom boundary conditions
         if(myparity.eq.1) then
            call mpi_send(spin(i2m,j1), 1, row_type, &
                 myid+1, D, mpi_comm_world, ierr)
            call mpi_recv(spin(i2,j1),  1, row_type, &
                 myid+1, D, mpi_comm_world, status, ierr)
            call mpi_send(spin(i1p,j1), 1, row_type, &
                 myid-1, H, mpi_comm_world, ierr)
            call mpi_recv(spin(i1,j1),  1, row_type, &
                 myid-1, H, mpi_comm_world, status, ierr)

         else                                                 !(myparity.eq.0)
            call mpi_send(spin(i1p,j1), 1, row_type, &
                 myid-1, D, mpi_comm_world, ierr)
            call mpi_recv(spin(i1,j1),  1, row_type, &
                 myid-1, D, mpi_comm_world, status, ierr)
            call mpi_send(spin(i2m,j1), 1, row_type, &
                 myid+1, H, mpi_comm_world, ierr)
            call mpi_recv(spin(i2,j1),  1, row_type, &
                 myid+1, H, mpi_comm_world, status, ierr)

         endif
      else

        ! top and bottom boundary conditions

         call mpi_send(spin(i2m,j1), 1, row_type, &
              0, D, mpi_comm_world, ierr)
         call mpi_recv(spin(i1,j1),  1, row_type, &
              myid-1, H, mpi_comm_world, status, ierr)
         call mpi_send(spin(i1p,j1), 1, row_type, &
              myid-1, H, mpi_comm_world, ierr)
         call mpi_recv(spin(i2,j1),  1, row_type, &
              0, D, mpi_comm_world, status, ierr)
        ! corners

         call mpi_recv(spin(i2, j2 ), 1, mpi_integer, &
              0, 2, mpi_comm_world, status, ierr)
         call mpi_send(spin(i2m,j2m), 1, mpi_integer, &
              0, 3, mpi_comm_world, ierr)
         call mpi_recv(spin(i2, j1 ), 1, mpi_integer, &
              0, 4, mpi_comm_world, status, ierr)
         call mpi_send(spin(i2m,j1p), 1, mpi_integer, &
              0, 5, mpi_comm_world, ierr)
      endif
end subroutine transfor_data
end program isingmodel_mpi


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   spb :    A singularly perturbed BVP
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION U1,U2,EPS,RL

       U1=U(1)
       U2=U(2)
       EPS=PAR(2)
       RL =PAR(3)

       F(1)=U2
       F(2)=RL * ( U1*(U1**2-1)*U2 + U1 ) / EPS

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,X)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: X

      DOUBLE PRECISION GAMMA,EPS,RL,S

       GAMMA=1.2
       EPS=0.1
       RL=0.

       PAR(1)=GAMMA
       PAR(2)=EPS
       PAR(3)=RL

       S=GAMMA-1.5
       U(1)=1.5 + S*X
       U(2)=S

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

       FB(1)=U0(1)-1.5
       FB(2)=U1(1)-PAR(1)

      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! minloc with back in parameter declaration

program main
  integer, parameter :: a(1) = minloc((/1,4,4,1/),back=.true.)
  call check(a(1), 4, 1)
end


submodule (auxiliary_routines) error_handlers

contains

    module procedure fft_consistent
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip) :: lcm
        !--------------------------------------------------------------

        !
        !==> Set least common multiple of inc and jump.
        !
        lcm = get_least_common_multiple(inc, jump)

        !
        !==> Check consistency
        !
        if ( lcm <= (n - 1) * inc .and. lcm <= (lot - 1) * jump ) then
            return_value = .false.
        else
            return_value = .true.
        end if

    end procedure fft_consistent

    pure function get_least_common_multiple(a, b) result (return_value)
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in) :: a
        integer (ip), intent (in) :: b
        integer (ip)              :: return_value
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip) :: i, j, jnew !! Counters
        !--------------------------------------------------------------

        i = a
        j = b

        do while (j /= 0)
            jnew = mod(i, j)
            i = j
            j = jnew
        end do

        ! Return least common multiple of a and b
        return_value = (a * b) / i

    end function get_least_common_multiple

    module procedure fft_error_handler

        use, intrinsic :: ISO_Fortran_env, only: stderr => ERROR_UNIT

        write (stderr, '(/a)') ' fftpack routine:: '
        write (stderr, '(a)') ' FATAL ERROR '

        select case (info)
            case (-1)
                write (stderr, '(4(a))') '  On entry to ', &
                    trim(subroutine_name), &
                    ' parameters lot, jump, n and inc are inconsistent.'
            case (-2)
                write (stderr, '(4(a))')  '  On ntry to ', &
                    trim(subroutine_name), &
                    ' parameter l is greater than ldim.'
            case (-3)
                write (stderr, '(4(a))')  '  On entry to ', &
                    trim(subroutine_name), &
                    ' parameter m is greater than mdim.'
            case (-5)
                write (stderr, '(4(a))')  '  Within ', &
                    trim(subroutine_name), &
                    ' input error returned by lower level routine.'
            case (-6)
                write (stderr, '(4(a))')  '  On entry to ', &
                    trim(subroutine_name), &
                    ' parameter ldim is less than 2*(l/2+1).'
            case default
                write (stderr, '(3(a),i3,a)') '  On entry to ',&
                    trim(subroutine_name),&
                    ' parameter number ', info, ' had an illegal value.'
        end select

    end procedure fft_error_handler

end submodule error_handlers