MODULE mo_boxcox

  ! This module contains routines to calculate the Box-Cox transformation
  ! as well as estimating the best exponent for the Box-Cox transformation

  ! Usage:
  ! USE mo_boxcox, ONLY: boxcox, get_boxcox
  ! lmbda    = get_boxcox(data)
  ! new_data = boxcox(data, lmbda)
  ! data     = invboxcox(new_data, lmbda)

  ! Written March 2011, Matthias Cuntz
  !   - modified Python code of Travis Oliphant (2002): boxcox, llf_boxcox, get_boxcox
  !   - modified numerical recipes: brent, mnbrak, swap, shft

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

  ! Note on Numerical Recipes License
  ! ---------------------------------
  ! Be aware that some code is under the Numerical Recipes License 3rd
  ! edition <http://www.nr.com/aboutNR3license.html>

  ! The Numerical Recipes Personal Single-User License lets you personally
  ! use Numerical Recipes code ("the code") on any number of computers,
  ! but only one computer at a time. You are not permitted to allow anyone
  ! else to access or use the code. You may, under this license, transfer
  ! precompiled, executable applications incorporating the code to other,
  ! unlicensed, persons, providing that (i) the application is
  ! noncommercial (i.e., does not involve the selling or licensing of the
  ! application for a fee), and (ii) the application was first developed,
  ! compiled, and successfully run by you, and (iii) the code is bound
  ! into the application in such a manner that it cannot be accessed as
  ! individual routines and cannot practicably be unbound and used in
  ! other programs. That is, under this license, your application user
  ! must not be able to use Numerical Recipes code as part of a program
  ! library or "mix and match" workbench.

  ! Businesses and organizations that purchase the disk or code download,
  ! and that thus acquire one or more Numerical Recipes Personal
  ! Single-User Licenses, may permanently assign those licenses, in the
  ! number acquired, to individual employees. Such an assignment must be
  ! made before the code is first used and, once made, it is irrevocable
  ! and can not be transferred.

  ! If you do not hold a Numerical Recipes License, this code is only for
  ! informational and educational purposes but cannot be used.

  USE mo_kind, ONLY: i4, sp, dp
  USE mo_utils, only: eq, le, ge

  IMPLICIT NONE

  PUBLIC :: boxcox     ! Calculate Box-Cox power transformed values given the original values and the exponent lambda
  PUBLIC :: get_boxcox ! Find the exponent that maximises the log-likelihood function
  PUBLIC :: invboxcox  ! Calculate the inverse Box-Cox given the transformed values and the exponent lambda

  ! ------------------------------------------------------------------

  !     NAME
  !         boxcox

  !     PURPOSE
  !         Transform a positive dataset with a Box-Cox power transformation.
  !             boxcox(x) = (x**lambda - 1)/lambda    if lambda <> 0
  !                         ln(x)                     if lambda = 0
  !
  !         If an optinal mask is given, then the Box-Cox transformation is only performed on
  !         those locations that correspond to true values in the mask.
  !         x can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         out = boxcox(x, lmbda, mask=mask)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)       1D-array with input numbers (>0.)
  !         real(sp/dp) :: lmbda      Exponent power of Box-Cox transform (>= 0.)

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: boxcox     Power transformed values (at mask=.True.)

  !     INTENT(IN), OPTIONAL
  !         logical :: mask(:)        1D-array of logical values with size(x).
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         Input values must be positive, i.e. > 0.

  !     EXAMPLE
  !         lmbda    = get_boxcox(data, mask=(data>0.))
  !         new_data = boxcox(data, lmbda, mask=(data>0.))
  !         idata    = invboxcox(new_data, lmbda, mask=(data>0.))
  !         -> see also example in test directory

  !     HISTORY
  !         Written,  Matthias Cuntz, March 2011
  !            - Modified Python code of Travis Oliphant (2002): boxcox, llf_boxcox, get_boxcox
  !            - Modified numerical recipes: brent, mnbrak, swap, shft
  INTERFACE boxcox
     MODULE PROCEDURE boxcox_sp, boxcox_dp
  END INTERFACE boxcox

  ! ------------------------------------------------------------------

  !     NAME
  !         get_boxcox

  !     PURPOSE
  !         Get lambda for Box-Cox transformation.
  !
  !         Transform a positive dataset with a Box-Cox power transformation.
  !             boxcox(x) = (x**lambda - 1)/lambda    if lambda <> 0
  !                         ln(x)                     if lambda = 0
  !
  !         If an optinal mask is given, then the Box-Cox transformation is only performed on
  !         those locations that correspond to true values in the mask.
  !         x can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         out = get_boxcox(x, mask=mask)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)       1D-array with input numbers (>0.)

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: lambda     Lambda for power transformed values (at mask=.True.)

  !     INTENT(IN), OPTIONAL
  !         logical :: mask(:)        1D-array of logical values with size(x).
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         Input values must be positive, i.e. > 0.

  !     EXAMPLE
  !         lmbda    = get_boxcox(data, mask=(data>0.))
  !         new_data = boxcox(data, lmbda, mask=(data>0.))
  !         idata    = invboxcox(new_data, lmbda, mask=(data>0.))
  !         -> see also example in test directory

  !     HISTORY
  !         Written,  Matthias Cuntz, March 2011
  !            - Modified Python code of Travis Oliphant (2002): boxcox, llf_boxcox, get_boxcox
  !            - Modified numerical recipes: brent, mnbrak, swap, shft
  INTERFACE get_boxcox
     MODULE PROCEDURE get_boxcox_sp, get_boxcox_dp
  END INTERFACE get_boxcox

  ! ------------------------------------------------------------------

  !     NAME
  !         invboxcox

  !     PURPOSE
  !         Back-transformation of Box-Cox-transformed data.
  !             boxcox(x)    = (x**lambda - 1)/lambda        if lambda <> 0
  !                            ln(x)                         if lambda = 0
  !             invboxcox(y) = (lambda*y + 1)**(1/lambda)    if lambda <> 0
  !                            exp(y)                        if lambda = 0
  !
  !         If an optinal mask is given, then the inverse Box-Cox transformation is only performed on
  !         those locations that correspond to true values in the mask.
  !         x can be single or double precision. The result will have the same numerical precision.
  !         x can be scalar or vector

  !     CALLING SEQUENCE
  !         out = invboxcox(x, lmbda)                   ! scalar x
  !         out = invboxcox(x, lmbda, mask=mask)        ! vector x

  !     INTENT(IN)
  !         real(sp/dp) :: x / x(:)   scalar/1D-array with input numbers (>0.)
  !         real(sp/dp) :: lmbda      Exponent power of Box-Cox transform (>= 0.)

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: boxcox     Back transformed values (at mask=.True.)

  !     INTENT(IN), OPTIONAL
  !         logical :: mask(:)        1D-array of logical values with size(x).
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.
  !                                   Only applicable if x is a 1D-array

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         lmbda    = get_boxcox(data, mask=(data>0.))
  !         new_data = boxcox(data, lmbda, mask=(data>0.))
  !         idata    = invboxcox(new_data, lmbda, mask=(data>0.))
  !         -> see also example in test directory

  !     HISTORY
  !         Written,  Matthias Cuntz, March 2011
  !            - Modified MC: Python code of Travis Oliphant (2002): boxcox, llf_boxcox, get_boxcox
  !            - Modified MC: numerical recipes: brent, mnbrak, swap, shft
  !            - Modified JM: scalar version of invboxcox
  INTERFACE invboxcox
     MODULE PROCEDURE invboxcox_0d_sp, invboxcox_0d_dp, invboxcox_1d_sp, invboxcox_1d_dp
  END INTERFACE invboxcox

  ! ------------------------------------------------------------------

  PRIVATE

  ! ------------------------------------------------------------------

CONTAINS

  ! ------------------------------------------------------------------

  FUNCTION boxcox_sp(x, lmbda, mask)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:), INTENT(in)           :: x
    REAL(sp),               INTENT(in)           :: lmbda
    LOGICAL,  DIMENSION(:), INTENT(in), OPTIONAL :: mask
    REAL(sp), DIMENSION(size(x))                 :: boxcox_sp

    LOGICAL, DIMENSION(size(x)) :: maske
    REAL(sp)                    :: lmbda1

    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(x)) stop 'Error boxcox_sp: size(mask) /= size(x)'
       maske = mask
    endif
    if (any((le(x,0.0_sp)) .and. maske)) stop 'Error boxcox_sp: x <= 0'
    if (abs(lmbda) .lt. tiny(0.0_sp)) then
       where (maske)
          boxcox_sp = log(x)
       elsewhere
          boxcox_sp = x
       end where
    else
       lmbda1    = 1.0_sp / lmbda
       boxcox_sp = merge((exp(lmbda*log(x)) - 1.0_sp) * lmbda1, x, maske)
    endif

  END FUNCTION boxcox_sp

  FUNCTION boxcox_dp(x, lmbda, mask)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:), INTENT(in)           :: x
    REAL(dp),               INTENT(in)           :: lmbda
    LOGICAL,  DIMENSION(:), INTENT(in), OPTIONAL :: mask
    REAL(dp), DIMENSION(size(x))                 :: boxcox_dp

    LOGICAL, DIMENSION(size(x)) :: maske
    REAL(dp)                    :: lmbda1

    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(x)) stop 'Error boxcox_dp: size(mask) /= size(x)'
       maske = mask
    endif
    if (any((le(x,0.0_dp)) .and. maske)) then
       stop 'Error boxcox_dp: x <= 0'
    end if
    if (abs(lmbda) .lt. tiny(0.0_dp)) then
       where (maske)
          boxcox_dp = log(x)
       elsewhere
          boxcox_dp = x
       end where
    else
       lmbda1    = 1.0_dp / lmbda
       boxcox_dp = merge((exp(lmbda*log(x)) - 1.0_dp) * lmbda1, x, maske)
    endif

  END FUNCTION boxcox_dp

  ! ------------------------------------------------------------------

  ! Given a function f, and given a bracketing triplet of abscissas ax, bx, cx (such that bx is
  ! between ax and cx, and f(bx) is less than both f(ax) and f(cx)), this routine isolates
  ! the minimum to a fractional precision of about tol using Brent''s method. The abscissa of
  ! the minimum is returned.
  ! Parameters: Maximum allowed number of iterations; goldenratio; and a small number that
  ! protects against trying to achieve fractional accuracy for a minimum that happens to be
  ! exactly zero.
  Function brent_sp(ax, bx, cx, func_sp, tol, dat)

    IMPLICIT NONE

    REAL(sp),               INTENT(in) :: ax, bx, cx
    INTERFACE
       FUNCTION func_sp(x, da)
         USE mo_kind, ONLY: sp
         IMPLICIT NONE
         REAL(sp),               INTENT(in) :: x
         REAL(sp), DIMENSION(:), INTENT(in) :: da
         REAL(sp)                           :: func_sp
       END FUNCTION func_sp
    END INTERFACE
    REAL(sp),               INTENT(in) :: tol
    REAL(sp), DIMENSION(:), INTENT(in) :: dat
    REAL(sp)                           :: brent_sp

    INTEGER(i4), PARAMETER :: ITMAX = 500
    REAL(sp),    PARAMETER :: CGOLD = 0.3819660_sp
    REAL(sp),    PARAMETER :: ZEPS  = 1.0e-3_sp*epsilon(ax)
    INTEGER(i4) :: iter
    REAL(sp)    :: a, b, d, e, etemp, fu, fv, fw, fx
    REAL(sp)    :: p, q, r, tol1, tol2, u, v, w, x, xm

    d = 0.0_sp

    a  = min(ax,cx)
    b  = max(ax,cx)
    v  = bx
    w  = v
    x  = v
    e  = 0.0_sp
    fx = func_sp(x, dat)
    fv = fx
    fw = fx
    do iter=1, ITMAX
       xm   = 0.5_sp*(a+b)
       tol1 = tol*abs(x) + ZEPS
       tol2 = 2.0_sp*tol1
       if (le(abs(x-xm),(tol2-0.5_sp*(b-a)))) then
          brent_sp = x
          return
       end if
       if (abs(e) > tol1) then
          r = (x-w)*(fx-fv)
          q = (x-v)*(fx-fw)
          p = (x-v)*q-(x-w)*r
          q = 2.0_sp*(q-r)
          if (q > 0.0_sp) p = -p
          q     = abs(q)
          etemp = e
          e     = d
          if (ge(abs(p),abs(0.5_sp*q*etemp)) .or. &
               le(p,q*(a-x)) .or. ge(p,q*(b-x))) then
             e = merge(a-x, b-x, ge(x,xm))
             d = CGOLD*e
          else
             d = p/q
             u = x+d
             if (u-a < tol2 .or. b-u < tol2) d = sign(tol1,xm-x)
          end if
       else
          e = merge(a-x, b-x, ge(x,xm))
          d = CGOLD*e
       end if
       u  = merge(x+d, x+sign(tol1,d), ge(abs(d),tol1))
       fu = func_sp(u, dat)
       if (le(fu,fx)) then
          if (ge(u,x)) then
             a = x
          else
             b = x
          end if
          call shft_sp(v,w,x,u)
          call shft_sp(fv,fw,fx,fu)
       else
          if (u < x) then
             a = u
          else
             b = u
          end if
          if (le(fu,fw) .or. eq(w,x)) then
             v  = w
             fv = fw
             w  = u
             fw = fu
          else if (le(fu,fv) .or. eq(v,x) .or. eq(v,w)) then
             v  = u
             fv = fu
          end if
       end if
    end do
    ! If it comes to here, there were too much iterations
    STOP 'brent_sp: exceed maximum iterations'

  END FUNCTION brent_sp

  FUNCTION brent_dp(ax, bx, cx, func_dp, tol, dat)

    IMPLICIT NONE

    REAL(dp),               INTENT(in) :: ax, bx, cx
    INTERFACE
       FUNCTION func_dp(x, da)
         USE mo_kind, ONLY: dp
         IMPLICIT NONE
         REAL(dp),               INTENT(in) :: x
         REAL(dp), DIMENSION(:), INTENT(in) :: da
         REAL(dp)                           :: func_dp
       END FUNCTION func_dp
    END INTERFACE
    REAL(dp),               INTENT(in) :: tol
    REAL(dp), DIMENSION(:), INTENT(in) :: dat
    REAL(dp)                           :: brent_dp

    INTEGER(i4), PARAMETER :: ITMAX=500
    REAL(dp),    PARAMETER :: CGOLD=0.3819660_dp
    REAL(dp),    PARAMETER :: ZEPS=1.0e-3_dp*epsilon(ax)
    INTEGER(i4) :: iter
    REAL(dp)    :: a, b, d, e, etemp, fu, fv, fw, fx
    REAL(dp)    :: p, q, r, tol1, tol2, u, v, w, x, xm

    d = 0.0_dp

    a  = min(ax,cx)
    b  = max(ax,cx)
    v  = bx
    w  = v
    x  = v
    e  = 0.0_dp
    fx = func_dp(x, dat)
    fv = fx
    fw = fx
    do iter=1, ITMAX
       xm   = 0.5_dp*(a+b)
       tol1 = tol*abs(x) + ZEPS
       tol2 = 2.0_dp*tol1
       if (le(abs(x-xm),(tol2-0.5_dp*(b-a)))) then
          brent_dp = x
          return
       end if
       if (abs(e) > tol1) then
          r = (x-w)*(fx-fv)
          q = (x-v)*(fx-fw)
          p = (x-v)*q-(x-w)*r
          q = 2.0_dp*(q-r)
          if (q > 0.0_dp) p = -p
          q     = abs(q)
          etemp = e
          e     = d
          if (ge(abs(p),abs(0.5_dp*q*etemp)) .or. &
               le(p,q*(a-x)) .or. ge(p,q*(b-x))) then
             e = merge(a-x, b-x, ge(x,xm))
             d = CGOLD*e
          else
             d = p/q
             u = x+d
             if (u-a < tol2 .or. b-u < tol2) d = sign(tol1,xm-x)
          end if
       else
          e = merge(a-x, b-x, ge(x,xm))
          d = CGOLD*e
       end if
       u  = merge(x+d, x+sign(tol1,d), ge(abs(d),tol1))
       fu = func_dp(u, dat)
       if (le(fu,fx)) then
          if (ge(u,x)) then
             a = x
          else
             b = x
          end if
          call shft_dp(v,w,x,u)
          call shft_dp(fv,fw,fx,fu)
       else
          if (u < x) then
             a = u
          else
             b = u
          end if
          if (le(fu,fw) .or. eq(w,x)) then
             v  = w
             fv = fw
             w  = u
             fw = fu
          else if (le(fu,fv) .or. eq(v,x) .or. eq(v,w)) then
             v  = u
             fv = fu
          end if
       end if
    end do
    ! If it comes to here, there were too much iterations
    STOP 'brent_dp: exceed maximum iterations'

  END FUNCTION brent_dp

  ! ------------------------------------------------------------------

  ! Find the lambda that maximizes the log-likelihood function
  FUNCTION get_boxcox_sp(x, mask)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:), INTENT(in)           :: x
    LOGICAL,  DIMENSION(:), INTENT(in), OPTIONAL :: mask
    REAL(sp)                                     :: get_boxcox_sp

    REAL(sp), PARAMETER :: tol = 1.48e-08
    REAL(sp) :: ax, bx, cx
    REAL(sp) :: fa, fb, fc
    LOGICAL,  DIMENSION(size(x))        :: maske
    REAL(sp), DIMENSION(:), ALLOCATABLE :: xx
    INTEGER(i4) :: nn

    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(x)) stop 'Error get_boxcox_sp: size(mask) /= size(x)'
       maske = mask
    endif
    nn = count(maske)
    if (allocated(xx)) deallocate(xx)
    allocate(xx(nn))
    xx = pack(x, mask=maske)
    ax = -2.0_sp
    bx = 2.0_sp
    call mnbrak_sp(ax, bx, cx, fa, fb, fc, llf_boxcox_sp, xx)
    get_boxcox_sp = brent_sp(ax, bx, cx, llf_boxcox_sp, tol, xx)

  END FUNCTION get_boxcox_sp

  FUNCTION get_boxcox_dp(x, mask)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:), INTENT(in)           :: x
    LOGICAL,  DIMENSION(:), INTENT(in), OPTIONAL :: mask
    REAL(dp)                                     :: get_boxcox_dp

    REAL(dp), PARAMETER :: tol = 1.48e-08
    REAL(dp) :: ax, bx, cx
    REAL(dp) :: fa, fb, fc
    LOGICAL,  DIMENSION(size(x))        :: maske
    REAL(dp), DIMENSION(:), ALLOCATABLE :: xx
    INTEGER(i4) :: nn

    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(x)) stop 'Error get_boxcox_dp: size(mask) /= size(x)'
       maske = mask
    endif
    nn = count(maske)
    if (allocated(xx)) deallocate(xx)
    allocate(xx(nn))
    xx = pack(x, mask=maske)
    if (any(le(xx,0.0_dp))) then
       stop 'Error get_boxcox_dp: x <= 0'
    end if
    ax = -5.0_dp
    bx = 5.0_dp
    call mnbrak_dp(ax, bx, cx, fa, fb, fc, llf_boxcox_dp, xx)
    get_boxcox_dp = brent_dp(ax, bx, cx, llf_boxcox_dp, tol, xx)

  END FUNCTION get_boxcox_dp

  ! ------------------------------------------------------------------

  FUNCTION invboxcox_1d_sp(x, lmbda, mask)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:), INTENT(in)           :: x
    REAL(sp),               INTENT(in)           :: lmbda
    LOGICAL,  DIMENSION(:), INTENT(in), OPTIONAL :: mask
    REAL(sp), DIMENSION(size(x))                 :: invboxcox_1d_sp

    LOGICAL, DIMENSION(size(x))  :: maske
    REAL(sp)                     :: lmbda1
    REAL(sp), DIMENSION(size(x)) :: temp

    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(x)) stop 'Error invboxcox_1d_sp: size(mask) /= size(x)'
       maske = mask
    endif
    if (abs(lmbda) .lt. tiny(0.0_sp)) then
       where (maske)
          invboxcox_1d_sp = exp(x)
       elsewhere
          invboxcox_1d_sp = x
       end where
    else
       lmbda1    = 1.0_sp / lmbda
       temp      = lmbda*x+1.0_sp
       where (temp .gt. 0.0_sp)
          temp = exp(lmbda1*log(temp))
       elsewhere
          temp = 0.0_sp
       end where
       invboxcox_1d_sp = merge(temp, x, maske)
    endif

  END FUNCTION invboxcox_1d_sp

  FUNCTION invboxcox_1d_dp(x, lmbda, mask)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:), INTENT(in)           :: x
    REAL(dp),               INTENT(in)           :: lmbda
    LOGICAL,  DIMENSION(:), INTENT(in), OPTIONAL :: mask
    REAL(dp), DIMENSION(size(x))                 :: invboxcox_1d_dp

    LOGICAL, DIMENSION(size(x))  :: maske
    REAL(dp)                     :: lmbda1
    REAL(dp), DIMENSION(size(x)) :: temp

    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(x)) stop 'Error invboxcox_1d_dp: size(mask) /= size(x)'
       maske = mask
    endif
    if (abs(lmbda) .lt. tiny(0.0_dp)) then
       where (maske)
          invboxcox_1d_dp = exp(x)
       elsewhere
          invboxcox_1d_dp = x
       end where
    else
       lmbda1    = 1.0_dp / lmbda
       temp      = lmbda*x+1.0_dp
       where (temp .gt. 0.0_dp)
          temp = exp(lmbda1*log(temp))
       elsewhere
          temp = 0.0_dp
       end where
       invboxcox_1d_dp = merge(temp, x, maske)
    endif

  END FUNCTION invboxcox_1d_dp

  FUNCTION invboxcox_0d_sp(x, lmbda)

    IMPLICIT NONE

    REAL(sp), INTENT(in)           :: x
    REAL(sp), INTENT(in)           :: lmbda
    REAL(sp)                       :: invboxcox_0d_sp

    REAL(sp)                       :: lmbda1
    REAL(sp)                       :: temp

    if (abs(lmbda) .lt. tiny(0.0_sp)) then
       invboxcox_0d_sp = exp(x)
    else
       lmbda1    = 1.0_sp / lmbda
       temp      = lmbda*x+1.0_sp
       if (temp .gt. 0.0_sp) then
          temp = exp(lmbda1*log(temp))
       else
          temp = 0.0_sp
       end if
       invboxcox_0d_sp = temp
    endif

  END FUNCTION invboxcox_0d_sp

  FUNCTION invboxcox_0d_dp(x, lmbda)

    IMPLICIT NONE

    REAL(dp), INTENT(in)           :: x
    REAL(dp), INTENT(in)           :: lmbda
    REAL(dp)                       :: invboxcox_0d_dp

    REAL(dp)                       :: lmbda1
    REAL(dp)                       :: temp

    if (abs(lmbda) .lt. tiny(0.0_dp)) then
       invboxcox_0d_dp = exp(x)
    else
       lmbda1    = 1.0_dp / lmbda
       temp      = lmbda*x+1.0_dp
       if (temp .gt. 0.0_dp) then
          temp = exp(lmbda1*log(temp))
       else
          temp = 0.0_dp
       end if
       invboxcox_0d_dp = temp
    endif

  END FUNCTION invboxcox_0d_dp

  ! ------------------------------------------------------------------

  ! The boxcox (negative) log-likelihood function.
  FUNCTION llf_boxcox_sp(lmbda, x)

    IMPLICIT NONE

    REAL(sp),               INTENT(in) :: lmbda
    REAL(sp), DIMENSION(:), INTENT(in) :: x
    REAL(sp)                           :: llf_boxcox_sp

    REAL(sp), DIMENSION(size(x)) :: y
    REAL(sp)                     :: N, my, f, s

    N             = real(size(x),sp)
    y             = boxcox_sp(x, lmbda)
    my            = sum(y) / N
    f             = (lmbda-1.0_sp) * sum(log(x))

    ! f = f - 0.5_dp*N * log(sum((y-my)*(y-my))/N)
    s             = Min( huge(1.0_sp)/N , Max( N*tiny(1.0_sp) , sum((y-my)*(y-my)) ) )
    f             = f - 0.5_sp*N * log(s/N)

    llf_boxcox_sp = -f

  END FUNCTION llf_boxcox_sp

  FUNCTION llf_boxcox_dp(lmbda, x)

    IMPLICIT NONE

    REAL(dp),               INTENT(in) :: lmbda
    REAL(dp), DIMENSION(:), INTENT(in) :: x
    REAL(dp)                           :: llf_boxcox_dp

    REAL(dp), DIMENSION(size(x)) :: y
    REAL(dp)                     :: N, my, f, s

    N             = real(size(x),dp)
    y             = boxcox_dp(x, lmbda)
    my            = sum(y) / N
    f             = (lmbda-1.0_dp) * sum(log(x))

    ! f = f - 0.5_dp*N * log(sum((y-my)*(y-my))/N)
    s             = Min( huge(1.0_dp)/N , Max( N*tiny(1.0_dp) , sum((y-my)*(y-my)) ) )
    f             = f - 0.5_dp*N * log(s/N)

    llf_boxcox_dp = -f

  END FUNCTION llf_boxcox_dp

  ! ------------------------------------------------------------------

  ! Given a function func, and given distinct initial points ax and bx, this routine searches
  ! in the downhill direction (defined by the functionas evaluated at the initial points) and
  ! returns new points ax, bx, cx that bracket a minimum of the function.
  ! Parameters: GOLD is the default ratio by which successive intervals are magnified; GLIMIT
  ! is the maximum magnification allowed for a parabolic-fit step.
  SUBROUTINE mnbrak_sp(ax, bx, cx, fa, fb, fc, func_sp, dat)

    IMPLICIT NONE

    REAL(sp),               INTENT(inout) :: ax, bx
    REAL(sp),               INTENT(out)   :: cx
    REAL(sp),               INTENT(out)   :: fa, fb, fc
    INTERFACE
       FUNCTION func_sp(x, da)
         USE mo_kind, ONLY: sp
         IMPLICIT NONE
         REAL(sp),               INTENT(in) :: x
         REAL(sp), DIMENSION(:), INTENT(in) :: da
         REAL(sp)                           :: func_sp
       END FUNCTION func_sp
    END INTERFACE
    REAL(sp), DIMENSION(:), INTENT(in) :: dat

    REAL(sp), PARAMETER :: GOLD   = 1.618034_sp
    REAL(sp), PARAMETER :: GLIMIT = 100.0_sp
    REAL(sp), PARAMETER :: TINY   = 1.0e-20_sp
    REAL(sp) :: fu, q, r, u, ulim

    fa = func_sp(ax, dat)
    fb = func_sp(bx, dat)
    if (fb > fa) then
       call swap_sp(ax,bx)
       call swap_sp(fa,fb)
    end if
    cx = bx + GOLD*(bx-ax)
    fc = func_sp(cx, dat)
    do
       if (fb < fc) return
       r    = (bx-ax)*(fb-fc)
       q    = (bx-cx)*(fb-fa)
       u    = bx-((bx-cx)*q-(bx-ax)*r)/(2.0_sp*sign(max(abs(q-r),TINY),q-r))
       ulim = bx + GLIMIT*(cx-bx)
       if ((bx-u)*(u-cx) > 0.0_sp) then
          fu = func_sp(u, dat)
          if (fu < fc) then
             ax = bx
             fa = fb
             bx = u
             fb = fu
             return
          else if (fu > fb) then
             cx = u
             fc = fu
             return
          end if
          u  = cx + GOLD*(cx-bx)
          fu = func_sp(u, dat)
       else if ((cx-u)*(u-ulim) > 0.0_sp) then
          fu = func_sp(u, dat)
          if (fu < fc) then
             bx = cx
             cx = u
             u  = cx + GOLD*(cx-bx)
             call shft_sp(fb,fc,fu,func_sp(u, dat))
          end if
       else if (ge((u-ulim)*(ulim-cx),0.0_sp)) then
          u  = ulim
          fu = func_sp(u, dat)
       else
          u  = cx + GOLD*(cx-bx)
          fu = func_sp(u, dat)
       end if
       call shft_sp(ax,bx,cx,u)
       call shft_sp(fa,fb,fc,fu)
    end do

  END SUBROUTINE mnbrak_sp

  SUBROUTINE mnbrak_dp(ax, bx, cx, fa, fb, fc, func_dp, dat)

    IMPLICIT NONE

    REAL(dp),               INTENT(inout) :: ax, bx
    REAL(dp),               INTENT(out)   :: cx
    REAL(dp),               INTENT(out)   :: fa, fb, fc
    INTERFACE
       FUNCTION func_dp(x, da)
         USE mo_kind, ONLY: dp
         IMPLICIT NONE
         REAL(dp),               INTENT(in) :: x
         REAL(dp), DIMENSION(:), INTENT(in) :: da
         REAL(dp)                           :: func_dp
       END FUNCTION func_dp
    END INTERFACE
    REAL(dp), DIMENSION(:), INTENT(in) :: dat

    REAL(dp), PARAMETER :: GOLD   = 1.618034_dp
    REAL(dp), PARAMETER :: GLIMIT = 100.0_dp
    REAL(dp), PARAMETER :: TINY   = 1.0e-20_dp
    REAL(dp) :: fu, q, r, u, ulim

    fa = func_dp(ax, dat)
    fb = func_dp(bx, dat)
    if (fb > fa) then
       call swap_dp(ax,bx)
       call swap_dp(fa,fb)
    end if
    cx = bx + GOLD*(bx-ax)
    fc = func_dp(cx, dat)
    do
       if (fb < fc) return
       r    = (bx-ax)*(fb-fc)
       q    = (bx-cx)*(fb-fa)
       u    = bx-((bx-cx)*q-(bx-ax)*r)/(2.0_dp*sign(max(abs(q-r),TINY),q-r))
       ulim = bx + GLIMIT*(cx-bx)
       if ((bx-u)*(u-cx) > 0.0_dp) then
          fu = func_dp(u, dat)
          if (fu < fc) then
             ax = bx
             fa = fb
             bx = u
             fb = fu
             return
          else if (fu > fb) then
             cx = u
             fc = fu
             return
          end if
          u  = cx + GOLD*(cx-bx)
          fu = func_dp(u, dat)
       else if ((cx-u)*(u-ulim) > 0.0_dp) then
          fu = func_dp(u, dat)
          if (fu < fc) then
             bx = cx
             cx = u
             u  = cx + GOLD*(cx-bx)
             call shft_dp(fb,fc,fu,func_dp(u, dat))
          end if
       else if (ge((u-ulim)*(ulim-cx),0.0_dp)) then
          u  = ulim
          fu = func_dp(u, dat)
       else
          u  = cx + GOLD*(cx-bx)
          fu = func_dp(u, dat)
       end if
       call shft_dp(ax,bx,cx,u)
       call shft_dp(fa,fb,fc,fu)
    end do

  END SUBROUTINE mnbrak_dp

  ! ------------------------------------------------------------------

  ! Helper for brent and mnbrak
  SUBROUTINE shft_sp(a,b,c,d)

    IMPLICIT NONE

    REAL(sp), INTENT(out)   :: a
    REAL(sp), INTENT(inout) :: b,c
    REAL(sp), INTENT(in)    :: d

    a = b
    b = c
    c = d

  END SUBROUTINE shft_sp

  SUBROUTINE shft_dp(a,b,c,d)

    IMPLICIT NONE

    REAL(dp), INTENT(out)   :: a
    REAL(dp), INTENT(inout) :: b,c
    REAL(dp), INTENT(in)    :: d

    a = b
    b = c
    c = d

  END SUBROUTINE shft_dp

  ! ------------------------------------------------------------------

  ! Helper for mnbrak
  SUBROUTINE swap_sp(a,b)

    IMPLICIT NONE

    REAL(sp), INTENT(inout) :: a, b
    REAL(sp) :: dum
    dum = a
    a   = b
    b   = dum

  END SUBROUTINE swap_sp

  SUBROUTINE swap_dp(a,b)

    IMPLICIT NONE

    REAL(dp), INTENT(inout) :: a, b
    REAL(dp) :: dum
    dum = a
    a   = b
    b   = dum

  END SUBROUTINE swap_dp

END MODULE mo_boxcox


! NAME: PI SPMD ... a simple version.
! This program will numerically compute the integral of
!                   4/(1+x*x)
! from 0 to 1.  The value of this integral is pi -- which
! is great since it gives us an easy way to check the answer.

! The program was parallelized using OpenMP and an SPMD
! algorithm.  The following OpenMP specific lines were
! added:

! (1) A line to include omp.h -- the include file that
! contains OpenMP's function prototypes and constants.

! (2) A pragma that tells OpenMP to create a team of threads
! with an integer variable i being created for each thread.

! (3) two function calls: one to get the thread ID (ranging
! from 0 to one less than the number of threads), and the other
! returning the total number of threads.

! (4) A cyclic distribution of the loop by changing loop control
! expressions to run from the thread ID incremented by the number
! of threads.  Local sums accumlated into sum[id].

! Note that this program will show low performance due to
! false sharing.  In particular, sum(id) is unique to each
! thread, but adfacent values of this array share a cache line
! causing cache thrashing as the program runs.

! History: C code written by Tim Mattson, 11/1999
!          Adapted to Fortran code by Helen He and Tim Mattson, 09/2017
!          Changed to Fortran90 code by Helen He, 11/2020

  PROGRAM MAIN
  USE OMP_LIB
  IMPLICIT NONE

  INTEGER :: i, j, id, numthreads, nthreads
  INTEGER, PARAMETER :: num_steps = 100000000
  INTEGER, PARAMETER :: MAX_THREADS = 4
  INTEGER, PARAMETER :: PADDING = 8
  REAL*8 :: pi, step, full_sum, x
  REAL*8 :: start_time, run_time
  REAL*8 :: sum(0:MAX_THREADS-1, PADDING)

  step = 1.0 / num_steps

  start_time = OMP_GET_WTIME()

  DO j=1,MAX_THREADS

  CALL OMP_SET_NUM_THREADS(j)
  full_sum = 0.0
  start_time = omp_get_wtime()

!$OMP PARALLEL PRIVATE(id,x,numthreads)
  id = omp_get_thread_num()
  numthreads = OMP_GET_NUM_THREADS()
  sum(id,1) = 0.0

  IF (id == 0) THEN
      nthreads = numthreads
  ENDIF

  DO i = id, num_steps - 1, numthreads
     x = (i + 0.5) * step
     sum(id,1) = sum(id,1) + 4.0 / (1.0 + x * x)
  ENDDO
!$OMP END PARALLEL

  full_sum = 0.0
  DO i = 0, nthreads - 1
     full_sum = full_sum + sum(i,1)
  ENDDO

  pi = step * full_sum
  run_time = OMP_GET_WTIME() - start_time
  WRITE(*,100) pi, run_time, nthreads
100  FORMAT('pi is ',f15.8,' in ',f8.3,' secs and ',i3,' threads')

  ENDDO

  END PROGRAM MAIN


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the main program supplied by the user.
! This version illustrates an eigenvalue problem, the Schroedinger
! Equation for a simple harmonic oscillator.
!----------------------------------------------------

!       ------------
program phaml_master
!       ------------

!----------------------------------------------------
! This is the main program.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Local variables:

integer :: nvert,num_eval,nproc,print_err
real(my_real) :: lambda0
type(phaml_solution_type) :: pde1

!----------------------------------------------------
! Begin executable code

! Solve on a grid with 1000 vertices

nvert = 1000

! Find the eigenvalue closest to lambda0.  For the smallest eigenvalue,
! use -huge(0.0_my_real).  For interior eigenvalues, you must use a
! solver that handles indefinite problems, for example
! solver=LAPACK_INDEFINITE_SOLVER or solver=MUMPS_GEN_SOLVER

lambda0 = -huge(0.0_my_real)
!print *,"lambda0?"
!read *,lambda0

! Set the number of eigenvalues to compute.  It will compute the
! num_eval eigenvalues closest to lambda0.

num_eval = 1
print *,"number of eigenvalues?"
read *,num_eval

! Input number of processors

nproc=1
print *,"number of processors?"
read *,nproc

! Input the parameter that determines the width of the well.
! The smallest eigenvalue is sqrt(prob_param*(2 sqrt(3))).
! 25 is a nice easy one (gives an eigenvalue of 9.6592583...)

prob_param=25.0_my_real
!print *,"parameter that determines width of well (for example, 25.0)?"
!read *,prob_param

! Make sure prob_param is positive.

if (prob_param < 0.0_my_real) then
   print *,"the parameter must be positive; changing to ",abs(prob_param)
   prob_param = abs(prob_param)
endif

! The true solution is known for the smallest eigenvalue.  Print the error
! only if lambda0 is less than the smallest.  The error estimate, but not
! the actual error, will be printed for the other eigenvalues.

if (lambda0 < sqrt(2*prob_param)) then
   print_err = PHASES
else
   print_err = NEVER
endif

! Create the pde data structure

call phaml_create(pde1,nproc,eq_type=EIGENVALUE, &
!                  spawn_form=DEBUG_SLAVE, debug_command="gdb", &
                  draw_grid_who = MASTER)

! Send prob_param to the slaves

call update_usermod(pde1)

! Solve the problem

call phaml_solve_pde(pde1,                       &
                     max_vert=nvert,             &
                     sequential_vert=250,        &
                     print_grid_when=PHASES,     &
                     print_grid_who=MASTER,      &
                     print_error_when=print_err, &
                     print_error_who=MASTER,     &
                     print_error_what=ENERGY_LINF_ERR, &
                     print_errest_what=ENERGY_LINF_ERREST, &
                     print_eval_when=PHASES,     &
                     print_eval_who=MASTER,      &
                     draw_grid_when=PHASES,      &
                     mg_cycles=10,               &
                     mg_tol=MG_NO_TOL,           &
                     inc_quad_order=3,           &
                     lambda0 = lambda0,          &
                     num_eval = num_eval,        &
	             pause_after_phases = .true.,&
                     pause_at_start = .true.,    &
                     pause_at_end=.true.)

! Destroy the pde data structure

call phaml_destroy(pde1)

end program phaml_master


!*****************************************************************************************
!> author: Jacob Williams
!  date: 2012
!
!  Geometry routines.

    module geometry_module

    use kind_module,      only: wp
    use vector_module,    only: cross

    implicit none

    private

    !public routines:
    public :: locpt
    public :: distance_from_point_to_line
    public :: distance_from_point_to_line_segment
    public :: distance_from_point_to_path

    !unit test routine:
    public :: geometry_unit_test

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!  given a polygonal line connecting the vertices (x(i),y(i))
!  (i = 1,...,n) taken in this order. it is assumed that the
!  polygonal path is a loop, where (x(n),y(n)) = (x(1),y(1))
!  or there is an arc from (x(n),y(n)) to (x(1),y(1)).
!
!  (x0,y0) is an arbitrary point and l and m are variables.
!  l and m are assigned the following values:
!
!     l = -1   if (x0,y0) is outside the polygonal path
!     l =  0   if (x0,y0) lies on the polygonal path
!     l =  1   if (x0,y0) is inside the polygonal path
!
!  m = 0 if (x0,y0) is on or outside the path. if (x0,y0)
!  is inside the path then m is the winding number of the
!  path around the point (x0,y0).
!
!# History
!  * Original version from the NSWC Library
!  * Modified by J. Williams : 08/04/2012 : refactored to modern Fortran

    pure subroutine locpt (x0, y0, x, y, n, l, m)

    implicit none

    !arguments:
    integer,intent(in)               :: n
    real(wp),intent(in)              :: x0
    real(wp),intent(in)              :: y0
    real(wp),dimension(n),intent(in) :: x
    real(wp),dimension(n),intent(in) :: y
    integer,intent(out)              :: l
    integer,intent(out)              :: m

    !constants:
    real(wp),parameter :: eps = epsilon(1.0_wp)
    real(wp),parameter :: pi  = atan2(0.0_wp, -1.0_wp)
    real(wp),parameter :: pi2 = 2.0_wp*pi
    real(wp),parameter :: tol = 4.0_wp*eps*pi

    !local variables:
    integer  :: i,n0
    real(wp) :: u,v,theta1,sum,theta,angle,thetai

    n0 = n
    if (x(1) == x(n) .and. y(1) == y(n)) n0 = n - 1
    l = -1
    m = 0
    u = x(1) - x0
    v = y(1) - y0

    if (u == 0.0_wp .and. v == 0.0_wp) then

        l = 0  !(x0, y0) is on the boundary of the path

    else

        if (n0 >= 2) then

            theta1 = atan2(v, u)
            sum = 0.0_wp
            theta = theta1

            do i = 2,n0

                u = x(i) - x0
                v = y(i) - y0

                if (u == 0.0_wp .and. v == 0.0_wp) then
                    l = 0  !(x0, y0) is on the boundary of the path
                    exit
                end if

                thetai = atan2(v, u)
                angle = abs(thetai - theta)
                if (abs(angle - pi) < tol) then
                    l = 0  !(x0, y0) is on the boundary of the path
                    exit
                end if

                if (angle > pi) angle = angle - pi2
                if (theta > thetai) angle = -angle
                sum = sum + angle
                theta = thetai

            end do

            if (l/=0) then

                angle = abs(theta1 - theta)
                if (abs(angle - pi) < tol) then

                    l = 0  !(x0, y0) is on the boundary of the path

                else

                    if (angle > pi) angle = angle - pi2
                    if (theta > theta1) angle = -angle
                    sum = sum + angle    !sum = 2*pi*m where m is the winding number
                    m = abs(sum)/pi2 + 0.2_wp
                    if (m /= 0) then
                        l = 1
                        if (sum < 0.0_wp) m = -m
                    end if

                end if

            end if

        end if

    end if

    end subroutine locpt
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date:8/2012
!
!  Compute the distance between the point X and the line defined
!  by the two points X1 and X2.
!
!# References
!  1. http://mathworld.wolfram.com/Point-LineDistance2-Dimensional.html

    pure function distance_from_point_to_line (x1, x2, x) result(d)

    implicit none

    real(wp),dimension(3),intent(in) :: x1
    real(wp),dimension(3),intent(in) :: x2
    real(wp),dimension(3),intent(in) :: x
    real(wp)                         :: d

    real(wp),dimension(3) :: x21
    real(wp) :: x21_mag

    x21 = x2 - x1
    x21_mag = norm2(x21)

    if (x21_mag/=0.0_wp) then

        d = norm2( cross( x21, x1 - x ) ) / x21_mag

    else

        d = norm2(x1 - x)

    end if

    end function distance_from_point_to_line
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date:8/2012
!
!  Compute the distance between a line segment and a point.
!
!# References
!  1. http://forums.codeguru.com/showthread.php?194400-Distance-between-point-and-line-segment
!
!@note x,x1,x2 should all be the same length

    pure function distance_from_point_to_line_segment(x1, x2, x) result(d)

    implicit none

    real(wp),dimension(:),intent(in) :: x1
    real(wp),dimension(:),intent(in) :: x2
    real(wp),dimension(:),intent(in) :: x
    real(wp)                         :: d

    real(wp),dimension(size(x1)) :: x12
    real(wp) :: s
    real(wp) :: x12_mag

    x12 = x1 - x2
    x12_mag = norm2(x12)

    if (x12_mag==0.0_wp) then

        d = norm2(x1 - x)

    else

        s = dot_product( x1-x, x12 ) / dot_product( x12, x12 )

        !if the projection is not on the segment,
        ! then use the closest end point:
        if (s<0.0_wp) then
            s = 0.0_wp
        else if (s>1.0_wp) then
            s = 1.0_wp
        end if

        d = norm2( x - x1 + s*x12 )

    end if

    end function distance_from_point_to_line_segment
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date:8/2012
!
!  Compute the distance between a point and a polygonal path.
!  Given a point (x0,y0), and a path (x(n),y(n)), the distance
!  to the path is the distance to the closest line segment (x(i),y(i)).

    function distance_from_point_to_path(x0, y0, x, y, n) result(d)

    implicit none

    !arguments:
    integer,intent(in)                  :: n
    real(wp),intent(in)                 :: x0
    real(wp),intent(in)                 :: y0
    real(wp),dimension(n),intent(in)    :: x
    real(wp),dimension(n),intent(in)    :: y
    real(wp)                            :: d

    integer  :: l,m,i
    real(wp) :: dmin

    !is the point inside, outside, or on the path:
    call locpt (x0, y0, x, y, n, l, m)

    select case(l)

    case(1,-1)    !point is not on the path

        if (n==1) then

            !only one point in the path:
            d = norm2([x0-x(1), y0-y(1)])

        else

            do i=1,n    !loop through all line segments in the path
                        !the distance to the path is the distance from the closest line segment

                if (i<n) then
                    d = distance_from_point_to_line_segment( &
                            [x(i),y(i)], [x(i+1),y(i+1)], [x0,y0])
                else
                    !note: if 1st /= nth point, then have to check that line segment also.
                    if (x(1) /= x(n) .or. y(1) /= y(n)) then
                        d = distance_from_point_to_line_segment( &
                            [x(n),y(n)], [x(1),y(1)], [x0,y0])
                    end if
                end if

                !get lowest value:
                if (d<dmin .or. i==1) dmin = d

            end do

        end if

        !set sign of d:
        d = dmin * l   ! <0 if outside the path
                       ! >0 if inside the path

    case default    !point is on the path

        d = 0.0_wp

    end select

    end function distance_from_point_to_path
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date:8/2012
!
!  Unit test routine
!
!# Output
!
!    x0,y0=  0.59999999999999998       0.59999999999999998
!    l=           1
!    m=          -1
!    dist to path=  0.40000000000000002
!
!    x0,y0=   1.5000000000000000       0.50000000000000000
!    l=          -1
!    m=           0
!    dist to path= -0.50000000000000000
!
!    x0,y0=   1.0000000000000000        0.0000000000000000
!    l=           0
!    m=           0
!    dist to path=   0.0000000000000000

    subroutine geometry_unit_test()

    implicit none

    integer   :: l,m
    real(wp)  :: x0,y0

    !a 1x1 square:
    integer,parameter :: n = 4
    real(wp),dimension(n),parameter :: x = [0.0_wp, 0.0_wp, 1.0_wp, 1.0_wp]
    real(wp),dimension(n),parameter :: y = [0.0_wp, 1.0_wp, 1.0_wp, 0.0_wp]

    x0 = 0.6_wp    !inside the path
    y0 = 0.6_wp
    call go()

    x0 = 1.5_wp    !outside the path
    y0 = 0.5_wp
    call go()

    x0 = 10.0_wp   !outside the path
    y0 = 0.0_wp
    call go()

    x0 = 1.0_wp    !on the path
    y0 = 0.0_wp
    call go()

    contains

        subroutine go()    !call locpt for the x0,y0 point, and print results
          implicit none

          real(wp) :: d

          call locpt (x0, y0, x, y, n, l, m)

          write(*,*) ''
          write(*,*) 'x0,y0=',x0,y0
          write(*,*) 'l=',l
          write(*,*) 'm=',m

          d = distance_from_point_to_path(x0, y0, x, y, n)
          write(*,*) 'dist to path=',d

        end subroutine go

    end subroutine geometry_unit_test
!*****************************************************************************************

!*****************************************************************************************
    end module geometry_module
!*****************************************************************************************


module numz
! module defines the basic real type and pi
  integer, parameter:: d8 = selected_real_kind(14)
  integer, parameter:: d4 = selected_real_kind(5)
  real(d8), parameter :: pi = 3.141592653589793239_d8
end module
program doinv
use numz
implicit none
real(d8), allocatable ::  a8(:,:),b8(:,:)
real(d8) :: tot
integer n,nrhs
integer lda, ldb, info
integer,  allocatable :: ipiv(:)
logical :: do4,do8
integer stime,etime,rtime,mtime,m,i
character*1 trans
logical :: lu

nrhs=1
read(*,*,end=1234,err=1234)n,m,lu
goto 3456
1234 continue
n=2
m=10
lu=.true.
3456 continue
lda=n
ldb=n
allocate(ipiv(n))
tot=0.0

  allocate(a8(n,n))
  allocate(b8(n,nrhs))
  if(n .eq. 2)then
  a8(1,1)=1;
  a8(2,1)=6;
  a8(1,2)=3;
  a8(2,2)=7;
  b8(1,1)=2;
  b8(2,1)=4;
!octave:9> a8\b8
!ans =
!
!  -0.18182
!   0.72727
  else
  CALL RANDOM_NUMBER(a8)
  CALL RANDOM_NUMBER(b8)
  endif
  do i=1,m
      trans="N"
      call system_clock(stime, rtime,mtime)
      if (lu)then
      call dgetrf( n, n, a8, n, ipiv, info )
      call dgetrs(trans, n, nrhs, a8, lda, ipiv, b8, ldb, info)
      else
      call dgesv( n, nrhs, a8, lda, ipiv, b8, ldb, info )
      endif
!      call sgesv( n, nrhs, a8, lda, ipiv, b8, ldb, info )
      call system_clock(etime)
      if (etime .lt. stime)etime=etime+mtime
      tot=tot+real(etime - stime,d8) / real(rtime,d8)
      if(n .le. 10)write(*,*)b8
      if ( i .ne. m)then
         CALL RANDOM_NUMBER(a8)
         CALL RANDOM_NUMBER(b8)
      endif
  enddo
  print *, "size:",n,"  elapsed time: ",tot/m," did lu:",lu

end program


  subroutine setup_Gaussian_quadrature( &
    ngeomax,          maxintstr,  maxstr, &
    maxstr_internal,  vza,        sza,    &
    imuv,             imu0,       gmu,    &
    gwt,              gmumin)

!---------------------------------------------------------------------
! Subroutine:
!   setup_Gaussian_quadrature
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

  integer,intent(in):: &
    ngeomax,           &
    maxintstr,         &
    maxstr,            &
    maxstr_internal

  real(kind=dp),intent(in):: &
    vza(ngeomax), &
    sza(ngeomax)

  integer:: &
    iv,i

! Gaussian quadrature
! internals streams up and down
  real(kind=dp):: &
    intgmu(maxintstr), &
    intgwt(maxintstr)

  real(kind=dp):: &
    pi,deg2rad,rad2deg

! total streams up only
  real(kind=dp),intent(out):: &
    gmu(maxstr), &
    gwt(maxstr), &
    gmumin

  integer,intent(out):: &
    imuv(ngeomax),  &
    imu0(ngeomax)

!------------------------------------------------------

  pi = 2.d0*asin(1.d0)
  rad2deg = 180.d0/pi
  deg2rad = pi/180.d0

! Viewing angles
  do iv=1,ngeomax
!    index of viewing angles
     imuv(iv)      = maxintstr/2+iv
     gmu(imuv(iv)) = cos(vza(iv)*deg2rad)
     gwt(imuv(iv)) = 1.d0
!    index of solar zenith angles
     imu0(iv) = maxintstr/2+ngeomax+iv
     gmu(imu0(iv)) = cos(sza(iv)*deg2rad)
     gwt(imu0(iv)) = 1.d0
  enddo

! Setup Gaussian quadrature up and down
  call Gaussian_quadrature(maxintstr, intgmu, intgwt)

! save up (positive) angles in reverse order
! and determine minimum gmu angle (gmumin)
  do i=1,maxintstr/2
     gmu(i) = intgmu(maxintstr/2+1-i)
     gwt(i) = intgwt(maxintstr/2+1-i)
  enddo

! minimum angle of internal streams
  gmumin = minval(gmu(1:maxstr_internal))

  return
end subroutine setup_Gaussian_quadrature

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

subroutine Gaussian_quadrature(maxintstr, gmu, gwt)
!---------------------------------------------------------------------
!
! Gaussian_quadrature
!
! Set up Gaussian quadrature:
! The sign of gmu is chosen that DG_MU and -DG_MU denote the
! downward and upward direction, respectively. Thus, U0 is positive,
! and the direction of the direct beam is (U0,0) refering to the
! principle plane.
!
!---------------------------------------------------------------------
  implicit none
  integer,parameter::dp=selected_real_kind(8) !double precision
  integer,intent(in)::maxintstr
  integer::i
! temporary arrays
  real(kind=dp),dimension(maxintstr):: tmp_mu, tmp_wt
! Double Gaussian quadrature
  real(kind=dp),dimension(maxintstr),intent(out):: &
       gmu(maxintstr), &  !quadrature points
       gwt(maxintstr)     !quadrature weights
  if((maxintstr+1)/2.ne.maxintstr/2)then
      write(*,*) 'quad.f90: Bad value of maxintstr!'
      write(*,*) 'Choose an even integer for maxintstr.'
      stop
  endif
! maxintstr=2;  twostream, only up and down
  if(maxintstr.eq.2)then
     gmu(1) =  1.d0
     gmu(2) = -1.d0
     gwt(1) =  1.d0
     gwt(2) =  1.d0
     return
  endif
! only positive values are calculated
  call dgauss(maxintstr/2, tmp_mu, tmp_wt)
! downward direction
! sort maxintstr/2   -> 1,
!      maxintstr/2-1 -> 2, etc.
  do i=1,maxintstr/2
     gmu(maxintstr/2-i+1) = tmp_mu(i)
     gwt(maxintstr/2-i+1) = tmp_wt(i)
  enddo
! upward values
  do i=1,maxintstr/2
     gmu(maxintstr+1-i) = -gmu(i)
     gwt(maxintstr+1-i) =  gwt(i)
  enddo
  return
end subroutine Gaussian_quadrature

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

subroutine dgauss(M, gmu, gwt)
!----------------------------------------------------------------------
!
! dgauss
!
! Compute weights and abscissae for ordinary Gaussian quadrature
! (no weight function inside integral) on the interval (0,1)
!
! input :   M                      order of quadrature rule
!
! output :  gmu(I)  I = 1 TO M     array of abscissae
!           gwt(I)  I = 1 TO M     array of weights
!
! reference:  Davis, P.J. and P. Rabinowitz,
!                 Methods of Numerical Integration,
!                 Academic Press, New York, pp. 87, 1975.
!
! method:  Compute the abscissae as roots of the Legendre
!          polynomial P-sub-M using a cubically convergent
!          refinement of Newton's method.  Compute the
!          weights from EQ. 2.7.3.8 of Davis/Rabinowitz.  Note
!          that Newton's method can very easily diverge; only a
!          very good initial guess can guarantee convergence.
!          The initial guess used here has never led to divergence
!          even for M up to 1000.
!
! accuracy:  at least 13 significant digits
!
! internal variables:
!
!    ITER      : number of Newton Method iterations
!    MAXIT     : maximum allowed iterations of Newton Method
!    PM2,PM1,P : 3 successive Legendre polynomials
!    PPR       : derivative of Legendre polynomial
!    P2PRI     : 2nd derivative of Legendre polynomial
!    TOL       : convergence criterion for Legendre poly root iteration
!    X,XI      : successive iterates in cubically-convergent version
!                of Newtons Method (seeking roots of Legendre poly.)
!----------------------------------------------------------------------
  implicit none
  integer,parameter::dp=selected_real_kind(8) !double precision
  integer,intent(in)::M
  integer:: ITER, LIM, NP1, NN, k
  real(kind=dp):: CONA, PI, T
  real(kind=dp):: EN,  NNP1, P, PM1, PM2, PPR, P2PRI, PROD
  real(kind=dp):: tmp, X, XI
  real(kind=dp),parameter:: &
       MAXIT   =  1000,     &
       ONE     =  1.d0,     &
       TWO     =  2.d0,     &
       EPSILON =  1.d-14
  real(kind=dp),intent(out):: gmu(M), gwt(M)
!---------------------------------------------------------------------
  pi = 2.d0*DASIN(1.d0)
  if(M.LT.1)THEN
     WRITE(*,*) 'Dgauss -- Bad value of M'
     STOP
  endif
  if(M.EQ.1)THEN
     gmu(1) = 0.d0
     gwt(1) = 1.d0
  return
  endif
  EN   = M
  NP1  = M + 1
  NNP1 = M * NP1
  CONA = dble(M-1) / dble(8 * M**3)
  LIM = M / 2
  do k = 1,LIM
!    initial guess for k-th root of Legendre polynomial,
!    from Davis/Rabinowitz (2.7.3.3a)
     T = dble(4*k-1)*pi/dble(4*M+2)
     X = DCOS(T+CONA/DTAN(T))
     ITER = 0
!    upward recurrence for Legendre polynomials
10   ITER = ITER + 1
     PM2  = ONE
     PM1  = X
     do NN = 2,M
        P   = (dble(2*NN-1) * X * PM1 - dble(NN-1) * PM2 ) / dble(NN)
        PM2 = PM1
        PM1 = P
     enddo
!    Newton method
     tmp   = ONE / ( ONE - X**2 )
     PPR   = EN * ( PM2 - X * P ) * tmp
     P2PRI = ( TWO * X * PPR - NNP1 * P ) * tmp
     XI    = X - ( P / PPR ) * ( ONE + ( P / PPR ) * P2PRI / ( TWO * PPR ) )
!    check for convergence
     if(DABS(XI-X).GT.EPSILON)THEN
        if(ITER.GT.MAXIT)THEN
           WRITE(*,*)'dgauss -- MAX ITERATION COUNT'
           STOP
        endif
        X = XI
        GOTO 10
     endif
!    iteration finished--calculate weights, abscissae for (-1,1)
     gmu(k)     = -X
     gwt(k)     =  TWO / (tmp*(EN*PM2)**2)
     gmu(NP1-k) = -GMU(K)
     gwt(NP1-k) =  GWT(K)
  enddo
! set middle abscissa and weight for rules of odd order
  if(MOD(M,2).NE.0)THEN
     gmu(LIM+1) = 0.d0
     PROD = ONE
     do k = 3, M, 2
        PROD = PROD*dble(k)/dble(k-1)
     enddo
     gwt(LIM+ 1) = TWO/PROD**2
  endif
! convert from (-1,1) to (0,1) and re-sort
  do k=1,M
     gmu(k) = 0.5d0 * gmu(K) + 0.5d0
     gwt(k) = 0.5d0 * gwt(K)
  enddo
  return
end subroutine dgauss


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
program nex_analysis
  implicit none
  real(8),parameter :: dw=0.1d0/27.2d0 ! Energy resolution [eV/27.2 =a.u.]
  real(8),parameter :: Pi=3.141592653589793d0
  real(8),allocatable :: esp(:,:),occ(:,:)
  real(8),allocatable :: DoS(:),DoS_occ(:)
  real(8) :: esp_min,esp_max,esp_d
  real(8) :: wi,wf,w
  integer :: Nw,iw
  integer :: ik,ib,NK,NB

  read(*,*)
  read(*,*)NB,NK
  allocate(esp(NB,NK),occ(NB,NK))

  do ik=1,NK
    do ib=1,NB
      read(*,*)esp(ib,ik),occ(ib,ik)
    end do
  end do

  esp_min=minval(esp)
  esp_max=maxval(esp)

  esp_d=(esp_max-esp_min)*1.0d0
  wi=esp_min-esp_d*0.1
  wf=esp_max+esp_d*0.1

  Nw=aint((wf-wi)/(dw/10d0))+1
  allocate(DoS(0:Nw),DoS_occ(0:Nw))
  DoS=0d0
  DoS_occ=0d0

  do ik=1,NK
    do ib=1,NB
      do iw=0,Nw
        w=wi+dble(iw)*(dw/10d0)
        DoS(iw)=DoS(iw)+(2d0/dble(NK))*(1d0/sqrt(2d0*pi*dw**2))*exp(-0.5d0*((w-esp(ib,ik))/dw)**2)
        DoS_occ(iw)=DoS_occ(iw)+occ(ib,ik)*(1d0/sqrt(2d0*pi*dw**2))*exp(-0.5d0*((w-esp(ib,ik))/dw)**2)
      end do
    end do
  end do

  do iw=0,Nw
    w=wi+dble(iw)*(dw/10d0)
    write(*,'(100e26.16e3)')w,DoS(iw),DoS_occ(iw)
  end do

end program nex_analysis


      SUBROUTINE cosft1 (Y, N)
!
! This is a fast cosine transform routine
! from Numerical Recipes.  Computes the transform of Y(1:N+1) where N is
! power of two.  This is also the inverse transform but in that case
! multiply Y by 2/N.
!
      IMPLICIT NONE
      INTEGER n, j
      REAL(4) Y (N + 1), SUM, y1, y2
      REAL(8) WR, WI, WPR, WPI, WTEMP, THETA
      THETA = 3.141592653589793D0 / DBLE (n)
      WR = 1.0D0
      WI = 0.0D0
      WPR = - 2.0D0 * DSIN (0.5D0 * THETA) **2
      WPI = DSIN (THETA)
      SUM = .5d0 * (Y (1) - y (n + 1) )
      y (1) = .5d0 * (y (1) + y (n + 1) )
      DO 11 J = 1, n / 2 - 1
         WTEMP = WR
         WR = WR * WPR - WI * WPI + WR
         WI = WI * WPR + WTEMP * WPI + WI
         Y1 = 0.5d0 * (Y (J + 1) + Y (n - J + 1) )
         Y2 = (Y (J + 1) - Y (n - J + 1) )
         Y (J + 1) = Y1 - WI * Y2
         Y (n - J + 1) = Y1 + WI * Y2
         SUM = SUM + WR * Y2
11    END DO
      CALL realft (Y, n, + 1)
      y (n + 1) = y (2)
      Y (2) = SUM
      DO 12 J = 4, N, 2
         SUM = SUM + Y (J)
         Y (J) = SUM
12    END DO
      RETURN
      ENDSUBROUTINE COSFT1


! ==============================================================================
!  Point-wise version of the acoustics problem
! ==============================================================================

subroutine rp1_ptwise(num_eqn, num_aux, num_waves, q_l, q_r, aux_l, aux_r,    &
                      wave, s, amdq, apdq)

    implicit none

    ! Input Arguments
    integer, intent(in) :: num_eqn, num_aux, num_waves
    real(kind=8), intent(in out) :: q_l(num_eqn), q_r(num_eqn)
    real(kind=8), intent(in out) :: aux_l(num_aux), aux_r(num_aux)

    ! Output arguments
    real(kind=8), intent(in out) :: wave(num_eqn, num_waves)
    real(kind=8), intent(in out) :: s(num_waves)
    real(kind=8), intent(in out) :: apdq(num_eqn), amdq(num_eqn)

    ! Locals
    real(kind=8) :: delta(2), a(2)

    ! Common block
    real(kind=8) :: rho, bulk, cc, zz

    common /cparam/ rho, bulk, cc, zz

    delta = q_r - q_l

    a(1) = (-delta(1) + zz * delta(2)) / (2.d0 * zz)
    a(2) = ( delta(1) + zz * delta(2)) / (2.d0 * zz)

    wave(1, 1) = -a(1) * zz
    wave(2, 1) =  a(1)
    s(1) = -cc

    wave(1, 2) = a(2) * zz
    wave(2, 2) = a(2)
    s(2) = cc

    amdq = s(1) * wave(:, 1)
    apdq = s(2) * wave(:, 2)

end subroutine rp1_ptwise


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program test_hstcsp

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

    use fishpack

    ! Explicit typing only
    implicit none

    !-----------------------------------------------
    ! Dictionary
    !-----------------------------------------------
    type(FishpackWorkspace) :: workspace
    integer(ip), parameter  :: M = 45
    integer(ip), parameter  :: N = 15
    integer(ip), parameter  :: IDIMF = M + 2, NP1 = N + 1
    integer(ip)             :: mbdcnd, nbdcnd, i, j, intl, ierror
    real(wp)                :: f(IDIMF, NP1), r(N)
    real(wp), dimension(M)  :: bdd, theta, cost
    real(wp), dimension(1)  :: bda, bdb, bdc
    real(wp)                :: a, b, c, d
    real(wp)                :: dt, dr, elmbda, pertrb
    real(wp), parameter     :: ZERO = 0.0_wp, HALF = 0.5_wp, ONE = 1.0_wp
    !-----------------------------------------------

    ! Set domaiin
    a = ZERO
    b = PI
    c = ZERO
    d = ONE

    ! Set boundary conditions
    mbdcnd = 9
    nbdcnd = 5

    ! Set helmholtz constant
    elmbda = ZERO

    ! Define mesh sizes
    dt = (b - a)/M
    dr = (d - c)/N

    ! Define grid points theta(i) and cos(theta(i))
    do i = 1, M
        theta(i) = a + (real(i, kind=wp) - HALF) * dt
        cost(i) = cos(theta(i))
    end do

    ! Define grid points r(j)
    do j = 1, N
        r(j) = c + (real(j) - HALF) * dr
    end do

    ! Define boundary array bdd.
    ! bda, bdb, and bdc are one-dimensional dummy variables in this example
    bdd = cost**4

    ! Define right hand side of equation
    block
        real(wp), parameter :: TWELVE = 12.0_wp

        do i = 1, M
            f(i,:N) = TWELVE * (r(:N)*cost(i))**2
        end do
    end block

    ! Initialize call flag
    intl = 0

    ! Solve 2D axisymmetric Helmholtz equation on staggered grid
    call hstcsp(intl, a, b, M, mbdcnd, bda, bdb, c, d, N, nbdcnd, bdc, &
        bdd, elmbda, f, IDIMF, pertrb, ierror, workspace)

    ! Compute discretization error. The exact solution is
    !
    ! u(theta, r) = (r*cos(theta))**4
    !
    block
        real(wp), parameter :: KNOWN_ERROR = 0.558432375660800e-2_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(M,N)

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

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

        call check_output('hstcsp', ierror, KNOWN_ERROR, discretization_error)
    end block

    ! Release memory
    call workspace%destroy()

end program test_hstcsp


FUNCTION dsinint(xvalue) RESULT(fn_val)

!   DEFINITION:

!   This program calculates the value of the sine-integral defined as

!       DSININT(x) = Integral (0 to x) sin(t)/t  dt

!   The program uses rational approximations with the coefficients
!   given to 20sf. accuracy.

!   INPUT PARAMETER:

!     XVALUE - DOUBLE PRECISION - The argument to the function

!   MACHINE-DEPENDENT PARAMETERS:

!     XLOW - DOUBLE PRECISION - The absolute value below which
!                                    DSININT( x ) = x,
!                               to machine precision.
!                               The recommended value is
!                                    SQRT(18*EPSNEG)

!     XHIGH1 - DOUBLE PRECISION - The value above which
!                                DSININT(x) = pi/2 - cos(x)/x -sin(x)/x*x
!                                 to machine precision.
!                                 The recommended value is
!                                   SQRT(6/EPSNEG)

!     XHIGH2 - DOUBLE PRECISION - The value above which
!                                     DSININT(x) = pi/2
!                                 to machine precision.
!                                 The recommended value is
!                                     2 / min(EPS,EPSNEG)

!     XHIGH3 - DOUBLE PRECISION - The value above which it is not sensible
!                                 to compute COS or SIN. The recommended
!                                 value is     pi/EPS

!      Values of EPS and EPSNEG for certain machine/compiler
!      combinations can be found in the paper

!      W.J. CODY  Algorithm 665: MACHAR: A subroutine to dynamically
!      determine machine parameters, ACM Trans. Math. Soft. 14 (1988) 303-311.

!      The current code gives numerical values for XLOW,XHIGH1,XHIGH2,XHIGH3,
!      suitable for machines whose arithmetic conforms to the IEEE
!      standard. The codes will probably work on other machines
!      but might overflow or underflow for certain arguments.

!   AUTHOR: Allan MacLeod
!           Dept. of Mathematics and Statistics
!           University of Paisley
!           Scotland
!           (e-mail: macl_ms0@paisley.ac.uk)

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(14, 60)
REAL (dp), INTENT(IN) :: xvalue
REAL (dp)             :: fn_val

! Local variables

INTEGER   :: i, indsgn
REAL (dp) :: cx, fival, gival, sumden, sumnum, sx, x, xhigh, xsq

!  DATA VALUES

REAL (dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp, six = 6.0_dp, &
                        twelve = 12.0_dp
REAL (dp), PARAMETER :: piby2 = 1.5707963267948966192_dp

!  MACHINE-DEPENDENT PARAMETERS (SUITABLE FOR IEEE MACHINES)

REAL (dp), PARAMETER :: xlow = 4.47E-8_dp, xhigh1 = 2.32472E8_dp
REAL (dp), PARAMETER :: xhigh2 = 9.0072E15_dp, xhigh3 = 1.4148475E16_dp

!  VALUES FOR SINE-INTEGRAL FOR 0 <= |X| <= 6

REAL (dp), PARAMETER :: asintn(0:7) = (/ 1.0_dp,  &
          -0.44663998931312457298E-1_dp, 0.11209146443112369449E-2_dp,  &
          -0.13276124407928422367E-4_dp, 0.85118014179823463879E-7_dp,  &
          -0.29989314303147656479E-9_dp, 0.55401971660186204711E-12_dp, &
          -0.42406353433133212926E-15_dp /)
REAL (dp), PARAMETER :: asintd(0:7) = (/ 1.0_dp,  &
           0.10891556624243098264E-1_dp, 0.59334456769186835896E-4_dp,  &
           0.21231112954641805908E-6_dp, 0.54747121846510390750E-9_dp,  &
           0.10378561511331814674E-11_dp, 0.13754880327250272679E-14_dp,&
           0.10223981202236205703E-17_dp /)

!  VALUES FOR FI(X) FOR 6 <= X <= 12

REAL (dp), PARAMETER :: afn1(0:7) = (/ 0.99999999962173909991_dp,   &
          0.36451060338631902917E3_dp, 0.44218548041288440874E5_dp, &
          0.22467569405961151887E7_dp, 0.49315316723035561922E8_dp, &
          0.43186795279670283193E9_dp, 0.11847992519956804350E10_dp,&
          0.45573267593795103181E9_dp /)
REAL (dp), PARAMETER :: afd1(0:7) = (/ 1.0_dp, 0.36651060273229347594E3_dp,  &
                  0.44927569814970692777E5_dp, 0.23285354882204041700E7_dp,  &
                  0.53117852017228262911E8_dp, 0.50335310667241870372E9_dp,  &
                  0.16575285015623175410E10_dp, 0.11746532837038341076E10_dp /)

!   VALUES OF GI(X) FOR 6 <= X <=12

REAL (dp), PARAMETER :: agn1(0:8) = (/ 0.99999999920484901956_dp,     &
          0.51385504875307321394E3_dp, 0.92293483452013810811E5_dp,   &
          0.74071341863359841727E7_dp, 0.28142356162841356551E9_dp,   &
          0.49280890357734623984E10_dp, 0.35524762685554302472E11_dp, &
          0.79194271662085049376E11_dp, 0.17942522624413898907E11_dp /)
REAL (dp), PARAMETER :: agd1(0:8) = (/ 1.0_dp, 0.51985504708814870209E3_dp,  &
                  0.95292615508125947321E5_dp, 0.79215459679762667578E7_dp,  &
                  0.31977567790733781460E9_dp, 0.62273134702439012114E10_dp,  &
                  0.54570971054996441467E11_dp, 0.18241750166645704670E12_dp,  &
                  0.15407148148861454434E12_dp /)

!   VALUES FOR FI(X) FOR X > 12

REAL (dp), PARAMETER :: afn2(0:7) = (/ 0.19999999999999978257E1_dp,   &
          0.22206119380434958727E4_dp, 0.84749007623988236808E6_dp,   &
          0.13959267954823943232E9_dp, 0.10197205463267975592E11_dp,  &
          0.30229865264524075951E12_dp, 0.27504053804288471142E13_dp, &
          0.21818989704686874983E13_dp /)
REAL (dp), PARAMETER :: afd2(0:7) = (/ 1.0_dp, 0.11223059690217167788E4_dp,  &
                  0.43685270974851313242E6_dp, 0.74654702140658116258E8_dp,  &
                  0.58580034751805687471E10_dp, 0.20157980379272098841E12_dp,  &
                  0.26229141857684496445E13_dp, 0.87852907334918467516E13_dp /)

!   VALUES FOR GI(X) FOR X > 12

REAL (dp), PARAMETER :: agn2(0:8) = (/ 0.59999999999999993089E1_dp,   &
          0.96527746044997139158E4_dp, 0.56077626996568834185E7_dp,   &
          0.15022667718927317198E10_dp, 0.19644271064733088465E12_dp, &
          0.12191368281163225043E14_dp, 0.31924389898645609533E15_dp, &
          0.25876053010027485934E16_dp, 0.12754978896268878403E16_dp /)
REAL (dp), PARAMETER :: agd2(0:8) = (/ 1.0_dp, 0.16287957674166143196E4_dp,  &
                  0.96636303195787870963E6_dp, 0.26839734750950667021E9_dp,  &
                  0.37388510548029219241E11_dp, 0.26028585666152144496E13_dp,  &
                  0.85134283716950697226E14_dp, 0.11304079361627952930E16_dp,  &
                  0.42519841479489798424E16_dp /)

!   START COMPUTATION

x = xvalue
indsgn = 1
IF ( x < zero ) THEN
  x = -x
  indsgn = -1
END IF

!   CODE FOR 0 <= |X| <= 6

IF ( x <= six ) THEN
  IF ( x < xlow ) THEN
    fn_val = x
  ELSE
    sumnum = zero
    sumden = zero
    xsq = x * x
    DO i = 7 , 0 , -1
      sumnum = sumnum * xsq + asintn(i)
      sumden = sumden * xsq + asintd(i)
    END DO
    fn_val = x * sumnum / sumden
  END IF
END IF

!   CODE FOR 6 < |X| <= 12

IF ( x > six .AND. x <= twelve ) THEN
  sumnum = zero
  sumden = zero
  xsq = one / ( x * x )
  DO i = 7 , 0 , -1
    sumnum = sumnum * xsq + afn1(i)
    sumden = sumden * xsq + afd1(i)
  END DO
  fival = sumnum / ( x * sumden )
  sumnum = zero
  sumden = zero
  DO i = 8 , 0 , -1
    sumnum = sumnum * xsq + agn1(i)
    sumden = sumden * xsq + agd1(i)
  END DO
  gival = xsq * sumnum / sumden
  fn_val = piby2 - fival * COS(x) - gival * SIN(x)
END IF

!   CODE FOR |X| > 12

IF ( x > twelve ) THEN
  xhigh = MIN(xhigh2, xhigh3)
  IF ( x > xhigh ) THEN
    fn_val = piby2
  ELSE
    cx = COS(x)
    sx = SIN(x)
    xsq = one / ( x * x )
    IF ( x > xhigh1 ) THEN
      fn_val = piby2 - cx / x - sx * xsq
    ELSE
      sumnum = zero
      sumden = zero
      DO i = 7 , 0 , -1
        sumnum = sumnum * xsq + afn2(i)
        sumden = sumden * xsq + afd2(i)
      END DO
      fival =  ( one - xsq * sumnum / sumden ) / x
      sumnum = zero
      sumden = zero
      DO i = 8 , 0 , -1
        sumnum = sumnum * xsq + agn2(i)
        sumden = sumden * xsq + agd2(i)
      END DO
      gival =  ( one - xsq * sumnum / sumden ) * xsq
      fn_val = piby2 - cx * fival - sx * gival
    END IF
  END IF
END IF
IF ( indsgn == -1 ) fn_val = -fn_val
RETURN
END FUNCTION dsinint


      INTEGER FUNCTION FRACTRAN(N,P,Q,M)	!Notion devised by J. H. Conway.
Careful: the rule is N*P/Q being integer. N*6/3 is integer always because this is N*2/1, but 3 may not divide N.
Could check GCD(P,Q), dividing out the common denominator so MOD(N,Q) works.
       INTEGER*8 N	!The work variable. Modified!
       INTEGER M	!The number of fractions supplied.
       INTEGER P(M),Q(M)!The terms of the fractions.
       INTEGER I	!A stepper.
        DO I = 1,M	!Search the supplied fractions, P(i)/Q(i).
          IF (MOD(N,Q(I)).EQ.0) THEN	!Does the denominator divide N?
            N = N/Q(I)*P(I)	!Yes, compute N*P/Q but trying to dodge overflow.
            FRACTRAN = I	!Report the hit.
           RETURN		!Done!
          END IF	!Otherwise,
        END DO		!Try the next fraction in the order supplied.
        FRACTRAN = 0	!No hit.
      END FUNCTION FRACTRAN	!That's it! Even so, "Turing complete"...

      PROGRAM POKE
      INTEGER FRACTRAN		!Not the default type of function.
      INTEGER P(66),Q(66)	!Holds the fractions as P(i)/Q(i).
      INTEGER*8 N		!The working number.
      INTEGER I,IT,L,M		!Assistants.

      WRITE (6,1)	!Announce.
    1 FORMAT ("Interpreter for J.H. Conway's FRACTRAN language.")

Chew into an example programme.
      OPEN (10,FILE = "Fractran.txt",STATUS="OLD",ACTION="READ")	!Rather than compiled-in stuff.
      READ (10,*) L	!I need to know this without having to scan the input.
      WRITE (6,2) L	!Reveal in case of trouble.
    2 FORMAT (I0," fractions, as follow:")	!Should the input evoke problems.
      READ (10,*) (P(I),Q(I),I = 1,L)	!Ask for the specified number of P,Q pairs.
      WRITE (6,3) (P(I),Q(I),I = 1,L)	!Show what turned up.
    3 FORMAT (24(I0,"/",I0:", "))	!As P(i)/Q(i) pairs. The colon means that there will be no trailing comma.
      READ (10,*) N,M			!The start value, and the step limit.
      CLOSE (10)			!Finished with input.
      WRITE (6,4) N,M			!Hopefully, all went well.
    4 FORMAT ("Start with N = ",I0,", step limit ",I0)

Commence.
      WRITE (6,10) 0,N		!Splat a heading.
   10 FORMAT (/,"  Step  #F: N",/,I6,4X,": ",I0)	!Matched FORMAT 11.
      DO I = 1,M		!Here we go!
        IT = FRACTRAN(N,P,Q,L)		!Do it!
        WRITE (6,11) I,IT,N		!Show it!
   11   FORMAT (I6,I4,": ",I0)		!N last, as it may be big.
        IF (IT.LE.0) EXIT		!No hit, so quit.
      END DO			!The next step.
      END	!Whee!


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!*********************************************************!!
!! Objetivo: escrever um sistema que resolva a equação     !!
!! diferencial y''-5y'+10y=10x pelo método de Gauss Seidel !!
!!                                                         !!
!! Aluna: Laura Simonassi Raso de Paiva                    !!
!! Matrícula: 180021885                                    !!
!! Data: 10/11/2019                                        !!
!! Última modificação: 26/11/2019                          !!
!!*********************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program gauss_seidel

implicit none
real(kind=8), allocatable :: yini(:), yfin(:),x(:)
real(kind=8):: h,erro
integer:: n
integer:: i

open(unit=1, file='resultados.txt')

write(*,*) 'Escolha um valor para n'
read(*,*) n

allocate(x(n),yini(n),yfin(n))

x(1)=0.0d0
h=1.0d0/dfloat(n-1)
do i=1,n-1
  x(i+1)=x(i)+h
end do
yini=100.0d0*x

yfin=yini

do
  erro=0.0d0
  do i=2,n-1
     yfin(i)=((1.0d0-(5.0d0*h)/2.0d0)*yini(i+1) + (1.0d0+(5.0d0*h)/2.0d0)*yfin(i-1) - 10.0d0*(h**2.0d0)*x(i))/(2.0d0-10.0d0*(h**2.0d0))
     erro=erro+(yfin(i)-yini(i))**2
     yini(i)=yfin(i)
  end do
  erro=erro/sum(yini**2)
    if(erro <= 1.0d-10) exit
end do

do i =1,n
   write(1,*) x(i),yfin(i)
end do

close(1)
end program gauss_seidel


!> \file f2pCO2.f90
!! \BRIEF
!>    Module with f2pCO2 subroutine - compute pCO2 from fCO2, in situ T, atm pressure, hydrostatic pressure
MODULE mf2pCO2
CONTAINS
!>    Compute pCO2 from arrays of fCO2, in situ temp, atm pressure, & hydrostatic pressure
SUBROUTINE f2pCO2(fCO2, temp, Patm, p, N, pCO2)
  !    Purpose:
  !    Compute pCO2 from arrays of fCO2, in situ temp, atm pressure, & hydrostatic pressure

#if USE_PRECISION == 2
#   define SGLE(x)    (x)
#else
#   define SGLE(x)    REAL(x)
#endif

  USE msingledouble
  IMPLICIT NONE

  !> number of records
!f2py intent(hide) n
  INTEGER, intent(in) :: N

! INPUT variables
  !> oceanic fugacity of CO2 [uatm]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: fCO2
  !> in situ temperature [C]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: temp
  !> atmospheric pressure [atm]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: Patm
  !> hydrostatic pressure [db]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: p

! OUTPUT variables:
  !> oceanic partial pressure of CO2 [uatm]
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: pCO2

! LOCAL variables:
  REAL(kind=r8) :: dfCO2, dtemp, tk, dPatm, prb
  REAL(kind=r8) :: Ptot, Rgas_atm, B, Del, xCO2approx, xc2, fugcoeff
  REAL(kind=r8) :: dpCO2

  INTEGER :: i

! REAL(kind=r8) :: sw_ptmp
! EXTERNAL sw_ptmp

  DO i = 1,N
     dfCO2     = DBLE(fCO2(i))
     dtemp     = DBLE(temp(i))
     dPatm     = DBLE(Patm(i))
     tk = 273.15d0 + DBLE(temp(i))     !Absolute temperature (Kelvin)
     prb = DBLE(p(i)) / 10.0d0         !Pressure effect (prb is in bars)
     Ptot = dPatm + prb/1.01325d0      !Total pressure (atmospheric + hydrostatic) [atm]
     Rgas_atm = 82.05736_r8            !R in (cm3 * atm) / (mol * K)  from CODATA (2006)
!    To compute fugcoeff, we need 3 other terms (B, Del, xc2) as well as 3 others above (tk, Ptot, Rgas_atm)
     B = -1636.75d0 + 12.0408d0*tk - 0.0327957d0*(tk*tk) + 0.0000316528d0*(tk*tk*tk)
     Del = 57.7d0 - 0.118d0*tk
!    "x2" term often neglected (assumed = 1) in applications of Weiss's (1974) equation 9
!    x2 = 1 - x1 = 1 - xCO2 (it is very close to 1, but not quite)
!    Let's assume that xCO2 = fCO2. Resulting fugcoeff is identical to 8th digit after the decimal.
     xCO2approx = dfCO2 * 1.e-6_r8
     xc2 = (1.0d0 - xCO2approx)**2
     fugcoeff = exp( Ptot*(B + 2.0d0*xc2*Del)/(Rgas_atm*tk) )
     dpCO2 = dfCO2 / fugcoeff
     pCO2(i) = SGLE(dpCO2)
  END DO

  RETURN
END SUBROUTINE f2pCO2
END MODULE mf2pCO2


program ex24

    use utils

    implicit none

    real(rk) :: A(10,10)
    real(rk) :: B(10,10)
    real(rk) :: C(10,10)
    real(rk) :: v1(3)
    real(rk) :: v2(3)
    real(rk) :: dp

    call initRand()
    call randMat(A, -1.0_rk, 1.0_rk)
    call randMat(B, -1.0_rk, 1.0_rk)
    call printMatrix(A, 'A')
    call printMatrix(B, 'B')

    C = matmul(A, B)

    call printMatrix(C, 'C')

    v1 = (/1.0, 0.0, 0.0/)
    v2 = (/0.0, 1.0, 0.0/)
    dp = dot_product(v1, v2)

    print*, dp

end program ex24


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_rad_upper( n, gg, r )

!  Determine the radius r of the ball covering the ellipsoid E given
!  by { x | norm(G^T * x) <=1 ), where G is an n x n lower triangular
!  matrix.  The array gg contains the matrix G in packed format.

!  S.B. Pope  6/12/04

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: gg((n*(n+1))/2)
real(k_dp), intent(out) :: r

integer    :: itmax = 100  !  max. iterations in dgqt
real(k_dp) :: atol = 1.d-4, rtol = 1.d-4  !  tolerances for dgqt

integer    :: info, i, j, k
real(k_dp) :: gi((n*(n+1))/2), g(n,n), alpha, delta, par, f
real(k_dp) :: a(n,n), b(n), x(n), z(n), wa1(n), wa2(n)

!  Method:  E = { y | y^T * y <= 1 } where y = G^T * x.
!  Now  x^T * x = y^T * G^{-1} * G^{-T} * y.
!  Thus, with f(y) = -2 * y^T * G^{-1} * G^{-T} * y,
!  r = sqrt(-f(y_m) ), where y_m is the minimizer of f, subject to |y|<=1.

gi = gg
call dtptri( 'L', 'N', n, gi, info )  !  G^{-1} in packed format

!  unpack gi into g
k = 0
g = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  g(i,j) = gi(k)
   end do
end do
a = g

! B = alpha * B * op(A) = -2 * G^{-1} * G^{-T}

alpha = -2.d0
call dtrmm ( 'R', 'L', 'T', 'N', n, n, alpha, g, n, a, n )

delta = 1.d0
par   = 0.d0
b     = 0.d0
!  minimize f(y) = (1/2) * y^T * A * y + b^T * y,  subject to |y|<= delta
!                = -2 * y^T * G^{-1} * G^{-T} * y

call dgqt(n,a,n,b,delta,rtol,atol,itmax,par,f,x,info,z,wa1,wa2)

if( info >= 3 ) then
   write(0,*)'ell_rad_upper: dgqt incomplete convergence, info = ', info
endif

if( f > 0.d0 ) then
   write(0,*)'ell_rad_upper: f positive, f = ', f
   stop
endif

r = sqrt( -f )

return
end subroutine ell_rad_upper


program variables

  !
  !  Demonstrate some properties of variables
  !

  implicit none

  integer :: i
  integer(2) :: j
  integer(4) :: k
  integer(8) :: l

  real :: a
  real(4) :: b
  real(8) :: c

  write(*, *) 'Huge: ', huge(i), huge(j), huge(k), huge(l)
  write(*, *) 'Digits: ', digits(i), digits(j), digits(k), digits(l)

  write(*, *) ''

  write(*, *) 'Huge: ', huge(a), huge(b), huge(c)
  write(*, '(a,i,i,i)') 'Digits: ', digits(a), digits(b), digits(c)
  write(*, '(a8,e,e,e)') 'Epsilon: ', epsilon(a), epsilon(b), epsilon(c)
  write(*, '(a9,en,en,en)') 'Epsilon: ', epsilon(a), epsilon(b), epsilon(c)
  write(*, '(a10,3es)') 'Epsilon: ', epsilon(a), epsilon(b), epsilon(c)
  write(*, '(a11,3e20.10e4)') 'Epsilon: ', epsilon(a), epsilon(b), epsilon(c)

end program variables


module constants

    ! define various constants
    implicit none
    real(kind=8) :: pi, e
    save

    subroutine set_constants()
        implicit none
        pi = acos(-1.d0)
        e = exp(1.d0)
    end subroutine set_constants

end module constants