MODULE AS60

! Calculate the eigenvalues and eigenvectors of a real symmetric matrix.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp), PARAMETER  :: zero = 0.0_dp, one = 1.0_dp

CONTAINS

SUBROUTINE tdiag (n, tol, a, d, e, z, maxdim, ifault)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-12-03  Time: 12:16:20

INTEGER, INTENT(IN)      :: n
REAL (dp), INTENT(OUT)   :: tol
INTEGER, INTENT(IN OUT)  :: maxdim
REAL (dp), INTENT(IN)    :: a(maxdim,maxdim)
REAL (dp), INTENT(OUT)   :: d(maxdim)
REAL (dp), INTENT(OUT)   :: e(maxdim)
REAL (dp), INTENT(OUT)   :: z(maxdim,maxdim)
INTEGER, INTENT(OUT)     :: ifault

REAL (dp), PARAMETER  :: eta = 1.0D-37, eps = 1.0D-14

!    Algorithm as 60.1 appl.statist. (1973) vol.22 no.2

!    Reduces real symmetric matrix to tridiagonal form

!    tol is a machine dependent constant , tol = eta/eps , where
!    eta is the smallest positive number representable in the
!    computer and eps is the smallest positive number for which
!    1+eps.ne.1.

!      eta=eps*tol
!      eps=0.7105427358e-14
!      tol=0.3131513063e-293
!      precis=1.0e-14

!      NB
!        Real constants must be <= 15 decimal digits
!        the range of a real constant is from 1.0e-293 to 1.0e+322

INTEGER    :: i, i1, j, j1, k, l
REAL (dp)  :: f, g, h, hh

tol=eta/eps
ifault=1
IF (n <= 1) RETURN
ifault=0
DO  i=1,n
  z(i,1:i)=a(i,1:i)
END DO
i=n
DO  i1=2,n
  l=i-2
  f=z(i,i-1)
  g=zero
  IF (l < 1) GO TO 30
  g = SUM( z(i,1:l)**2 )
  30 h=g + f*f

!       If g is too small for orthogonality to be guaranteed, the
!       transformation is skipped

  IF (g > tol) GO TO 40
  e(i)=f
  d(i)=zero
  GO TO 100

  40 l=l+1
  g=SQRT(h)
  IF (f >= zero) g=-g
  e(i)=g
  h=h - f*g
  z(i,i-1)=f-g
  f=zero
  DO  j=1,l
    z(j,i)=z(i,j)/h
    g=zero

!       Form element of a * u

    DO  k=1,j
      g=g + z(j,k)*z(i,k)
    END DO
    IF (j >= l) GO TO 70
    j1=j+1
    DO  k=j1,l
      g=g + z(k,j)*z(i,k)
    END DO

!       Form element of p

    70 e(j)=g/h
    f=f + g*z(j,i)
  END DO

!       Form k

  hh=f/(h+h)

!       Form reduced a

  DO  j=1,l
    f=z(i,j)
    g=e(j)-hh*f
    e(j)=g
    DO  k=1,j
      z(j,k)=z(j,k) - f*e(k) - g*z(i,k)
    END DO
  END DO
  d(i)=h
  100 i=i-1
END DO
d(1)=zero
e(1)=zero

!       Accumulation of transformation matrices

DO  i=1,n
  l=i-1
  IF (d(i) == zero .OR. l == 0) GO TO 140
  DO  j=1,l
    g=zero
    DO  k=1,l
      g=g + z(i,k)*z(k,j)
    END DO
    DO  k=1,l
      z(k,j)=z(k,j) - g*z(k,i)
    END DO
  END DO
  140 d(i)=z(i,i)
  z(i,i)=one
  IF (l == 0) CYCLE
  DO  j=1,l
    z(i,j)=zero
    z(j,i)=zero
  END DO
END DO
RETURN
END SUBROUTINE tdiag

SUBROUTINE lrvt (n, precis, d, e, z, ifault, maxdim)

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(OUT)     :: precis
INTEGER, INTENT(IN)        :: maxdim
REAL (dp), INTENT(IN OUT)  :: d(maxdim)
REAL (dp), INTENT(OUT)     :: e(maxdim)
REAL (dp), INTENT(IN OUT)  :: z(maxdim,maxdim)
INTEGER, INTENT(OUT)       :: ifault

!    Algorithm AS 60.2 appl.statist. (1973) vol.22, no.2

!    Finds latent roots and vectors of tridiagonal matrix

INTEGER, PARAMETER    :: mits = 30
REAL (dp), PARAMETER  :: two = 2.0D0

INTEGER    :: i, i1, j, jj, k, l, m, m1, n1
REAL (dp)  :: b, c, f, g, h, p, pr, r, s

precis=1.0D-14
ifault=2
IF (n <= 1) RETURN
ifault=1
n1=n-1
DO  i=2,n
  e(i-1)=e(i)
END DO
e(n)=zero
b=zero
f=zero
DO  l=1,n
  jj=0
  h=precis*(ABS(d(l))+ABS(e(l)))
  IF (b < h) b=h

!       Look for small sub-diagonal element

  DO  m1=l,n
    m=m1
    IF (ABS(e(m)) <= b) EXIT
  END DO
  IF (m == l) GO TO 90
  40 IF (jj == mits) RETURN
  jj=jj+1

!       Form shift

  p=(d(l+1)-d(l))/(two*e(l))
  r=SQRT(p*p + one)
  pr=p+r
  IF (p < zero) pr=p-r
  h=d(l)-e(l)/pr
  DO  i=l,n
    d(i)=d(i)-h
  END DO
  f=f+h

!       QL transformation

  p=d(m)
  c=one
  s=zero
  m1=m-1
  i=m
  DO  i1=l,m1
    j=i
    i=i-1
    g=c*e(i)
    h=c*p
    IF (ABS(p) >= ABS(e(i))) GO TO 60
    c=p/e(i)
    r=SQRT(c*c + one)
    e(j)=s*e(i)*r
    s=one/r
    c=c/r
    GO TO 70
    60 c=e(i)/p
    r=SQRT(c*c + one)
    e(j)=s*p*r
    s=c/r
    c=one/r
    70 p=c*d(i) - s*g
    d(j)=h + s*(c*g + s*d(i))

!       Form vector

    DO  k=1,n
      h=z(k,j)
      z(k,j)=s*z(k,i) + c*h
      z(k,i)=c*z(k,i) - s*h
    END DO
  END DO
  e(l)=s*p
  d(l)=c*p
  IF (ABS(e(l)) > b) GO TO 40
  90 d(l)=d(l) + f
END DO

!       Order latent roots and vectors

DO  i=1,n1
  k=i
  p=d(i)
  i1=i+1
  DO  j=i1,n
    IF (d(j) <= p) CYCLE
    k=j
    p=d(j)
  END DO
  IF (k == i) CYCLE
  d(k)=d(i)
  d(i)=p
  DO  j=1,n
    p=z(j,i)
    z(j,i)=z(j,k)
    z(j,k)=p
  END DO
END DO
ifault=0
RETURN
END SUBROUTINE lrvt

END MODULE AS60


      subroutine krnlrowupdate( m, n, A, ldA, cvec, svec )

      implicit none

*
*     PURPOSE
*     =======
*
*     Applies a decreasing sequence of m - 1 row rotations to a
*     rectangular m-by-n matrix A.
*
*     More specifically, the following update of A is performed:
*
*       A := G(2) * G(3) * ... * G(m) * A
*
*     where G(k) for k = 2, 3, ..., m affects only rows k - 1 and k in
*     the following way. Let x denote row k - 1 and y denote row
*     k. Furthermore, define c = cvec(k) and s = svec(k). Then the
*     effect of G(k) * A is equivalent to the update
*
*       [ x ] := [ c  s ] * [ x ]
*       [ y ]    [-s  c ]   [ y ].
*
*
*     ARGUMENTS
*     =========
*
*     m             (input) INTEGER
*
*                   The number of rows in A.
*
*     n             (input) INTEGER
*
*                   The number of columns in A.
*
*     A             (input/output) DOUBLE PRECISION array
*                   dimension ldA-by-n
*
*                   The matrix A.
*
*     ldA           (input) INTEGER
*
*                   The column stride of A.
*
*     cvec          (input) DOUBLE PRECISION array
*                   dimension m
*
*                   cvec(k) is the c-parameter of G(k).
*
*     svec          (input) DOUBLE PRECISION array
*                   dimension m
*
*                   svec(k) is the s-parameter of G(k).
*

*
*     Constants.
*
      integer slabsz
      parameter( slabsz = 16 )

*
*     Scalar arguments.
*
      integer m, n, ldA

*
*     Array arguments.
*
      double precision A( ldA, * ), cvec( * ), svec( * )

*
*     Intrinsics.
*
      intrinsic min

*
*     Local scalars.
*
      integer i, j, jj, jend
      double precision c, s, x, y

      do jj = 1, n, slabsz
         jend = min( n, jj + slabsz - 1 )
         do i = m, 2, -1
            c = cvec( i )
            s = svec( i )
            do j = jj, jend
               x = A( i - 1, j )
               y = A( i    , j )
               A( i - 1, j ) =   c * x + s * y
               A( i    , j ) = - s * x + c * y
            end do
         end do
      end do

      end subroutine


!*****************************************************************************************
!>
!  Drag model

    module drag_module

    use kind_module

    implicit none

    private

    public :: drag_acceleration

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

!*****************************************************************************************
!>
!  Acceleration due to atmospheric drag.

    pure subroutine drag_acceleration(vrel,cd,area,m,rho,acc)

    implicit none

    real(wp),dimension(3),intent(in)  :: vrel   !! velocity relative to the atmosphere [km/s]
    real(wp),intent(in)               :: cd     !! spacecraft drag coefficient [--]
    real(wp),intent(in)               :: area   !! cross-section area [km^2]
    real(wp),intent(in)               :: m      !! spacecraft mass [kg]
    real(wp),intent(in)               :: rho    !! atmospheric density [kg/km^3]
    real(wp),dimension(3),intent(out) :: acc    !! drag acceleration vector [km/s^2]

    real(wp) :: vrel_mag  !! magnitude of the relative velocity [km/s]

    vrel_mag = norm2(vrel)

    acc = - (0.5_wp * rho * cd * area * vrel_mag / m) * vrel

    end subroutine drag_acceleration
!*****************************************************************************************

!*****************************************************************************************
    end module drag_module
!*****************************************************************************************


c     ==================================================================
      subroutine setaux(mbc,mx,my,mz,xlower,ylower,zlower,
     &                  dx,dy,dz,maux,aux)
c     ==================================================================
c
c     # set auxiliary arrays
c
c     # advection
c     #    aux(i,j,k,1) is u velocity on left face of cell
c     #    aux(i,j,k,2) is v velocity on bottom face of cell
c     #    aux(i,j,k,3) is w velocity on back face of cell
c
c
      implicit none

      integer  mx, my, mz, mbc, maux, i,j,k
      double precision xlower, ylower, zlower, dx, dy, dz,
     &      pi, pi2, dx2, dy2, dz2, compute_u, compute_v, compute_w
      double precision aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc)
      double precision xc(1-mbc:mx+mbc)
      double precision yc(1-mbc:my+mbc)
      double precision zc(1-mbc:mz+mbc)

      common /piconstants/ pi, pi2

      pi = 4.d0*atan(1.d0)
      pi2 = 2.d0*pi

c

      do i = 1-mbc,mx+mbc
         xc(i) = xlower + (i-0.5d0)*dx
      enddo

      do j = 1-mbc,my+mbc
         yc(j) = ylower + (j-0.5d0)*dy
      enddo

      do k = 1-mbc,mz+mbc
         zc(k) = zlower + (k-0.5d0)*dz
      enddo

      dx2 = 0.5d0*dx
      dy2 = 0.5d0*dy
      dz2 = 0.5d0*dz

      do  k = 1-mbc,mz+mbc
         do j = 1-mbc,my+mbc
            do i = 1-mbc,mx+mbc
               aux(1,i,j,k) = compute_u(xc(i)-dx2, yc(j),zc(k))
               aux(2,i,j,k) = compute_v(xc(i),yc(j)-dy2, zc(k))
               aux(3,i,j,k) = compute_w(xc(i),yc(j), zc(k)-dz2)
            enddo
         enddo
      enddo

      return
      end

      double precision function compute_u(x,y,z)
      implicit none
      double precision x,y,z,pi, pi2

      common /piconstants/ pi, pi2

      compute_u = 2.d0 * dsin(pi*x)**2 * dsin(pi2*y) * dsin(pi2*z)
      end

      double precision function compute_v(x,y,z)
      implicit none
      double precision x,y,z,pi, pi2

      common /piconstants/ pi, pi2

      compute_v = -dsin(pi2*x) * dsin(pi*y)**2 * dsin(pi2*z)
      end

      double precision function compute_w(x,y,z)
      implicit none
      double precision x,y,z,pi, pi2

      common /piconstants/ pi, pi2

      compute_w = -dsin(pi2*x) * dsin(pi2*y) * dsin(pi*z)**2
      end


module mod_polynomial
#include <messenger.h>
    use mod_kinds,  only: rk,ik
    use type_point, only: point_t

    use mod_legendre
    use mod_lagrange
    use mod_ordering
    implicit none

contains

    !> Return value of a term in a polynomial expansion at a specified (xi, eta, zeta) location.
    !!
    !!  @author Nathan A. Wukie
    !!
    !!  @param[in]  spacedim    Integer specifying whether to compute the 1D, 2D,
    !!                          or 3D expansion function.
    !!  @param[in]  nterms      Number of terms in the polynomial expansion.
    !!  @param[in]  mode        Integer of the mode in the expansion to be computed.
    !!  @param[in]  node        point_t containing (xi,eta,zeta) location on reference element.
    !!
    !-----------------------------------------------------------------------------------------
    function polynomial_val(spacedim,nterms,mode,node) result(polyval)
        integer(ik),    intent(in)  :: spacedim
        integer(ik),    intent(in)  :: nterms
        integer(ik),    intent(in)  :: mode
        real(rk),       intent(in)  :: node(3)

        real(rk)    :: polyval

        polyval = legendre_val(spacedim,mode,node(1),node(2),node(3))

    end function polynomial_val
    !*****************************************************************************************

    !>  Return directional derivative of a term in a polynomial expansion at a specified
    !!  (xi, eta, zeta) location.
    !!
    !!  @author Nathan A. Wukie
    !!
    !!  @param[in]  spacedim   Integer specifying whether to compute the 1D, 2D,
    !!                          or 3D expansion function.
    !!  @param[in]  nterms      Number of terms in the polynomial expansion.
    !!  @param[in]  mode        Integer of the mode in the expansion to be computed.
    !!  @param[in]  node        point_t containing (xi,eta,zeta) location on reference element.
    !!  @param[in]  dir         Integer indicating direction of the derivative (xi, eta, zeta).
    !!
    !----------------------------------------------------------------------------------------
    function dpolynomial_val(spacedim,nterms,mode,node,dir) result(dpolyval)
        integer(ik),    intent(in)  :: spacedim
        integer(ik),    intent(in)  :: nterms
        integer(ik),    intent(in)  :: mode
        real(rk),       intent(in)  :: node(3)
        integer(ik),    intent(in)  :: dir

        real(rk)    :: dpolyval

        dpolyval = dlegendre_val(spacedim,mode,node(1),node(2),node(3),dir)

    end function dpolynomial_val
    !****************************************************************************************

    !>  Return second/mixed derivative of a term in a polynomial expansion at a specified
    !!  (xi, eta, zeta) location.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/7/2017
    !!
    !!  @param[in]  spacedim   Integer specifying whether to compute the 1D, 2D,
    !!                          or 3D expansion function.
    !!  @param[in]  nterms      Number of terms in the polynomial expansion.
    !!  @param[in]  mode        Integer of the mode in the expansion to be computed.
    !!  @param[in]  node        point_t containing (xi,eta,zeta) location on reference element.
    !!  @param[in]  dir         Integer indicating direction of the derivative (xi, eta, zeta).
    !!
    !----------------------------------------------------------------------------------------
    function ddpolynomial_val(spacedim,nterms,mode,node,partial1,partial2) result(res)
        integer(ik),    intent(in)  :: spacedim
        integer(ik),    intent(in)  :: nterms
        integer(ik),    intent(in)  :: mode
        real(rk),       intent(in)  :: node(3)
        integer(ik),    intent(in)  :: partial1
        integer(ik),    intent(in)  :: partial2

        real(rk)    :: res

        res = ddlegendre_val(spacedim,mode,node(1),node(2),node(3),partial1,partial2)

    end function ddpolynomial_val
    !****************************************************************************************

end module mod_polynomial


      SUBROUTINE cumt(t,df,cum,ccum)
C**********************************************************************
C
C     SUBROUTINE CUMT(T,DF,CUM,CCUM)
C                    CUMulative T-distribution
C
C
C                              Function
C
C
C     Computes the integral from -infinity to T of the t-density.
C
C
C                              Arguments
C
C
C     T --> Upper limit of integration of the t-density.
C                                                  T is DOUBLE PRECISION
C
C     DF --> Degrees of freedom of the t-distribution.
C                                                  DF is DOUBLE PRECISIO
C
C     CUM <-- Cumulative t-distribution.
C                                                  CCUM is DOUBLE PRECIS
C
C     CCUM <-- Compliment of Cumulative t-distribution.
C                                                  CCUM is DOUBLE PRECIS
C
C
C                              Method
C
C
C     Formula 26.5.27   of     Abramowitz  and   Stegun,    Handbook  of
C     Mathematical Functions  is   used   to  reduce the  t-distribution
C     to an incomplete beta.
C
C**********************************************************************

C     .. Scalar Arguments ..
      DOUBLE PRECISION df,t,cum,ccum
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION xx,a,oma,tt,yy,dfptt
C     ..
C     .. External Subroutines ..
      EXTERNAL cumbet
C     ..
C     .. Executable Statements ..
      tt = t*t
      dfptt = df + tt
      xx = df/dfptt
      yy = tt/dfptt
      CALL cumbet(xx,yy,0.5D0*df,0.5D0,a,oma)
      IF (.NOT. (t.LE.0.0D0)) GO TO 10
      cum = 0.5D0*a
      ccum = oma + cum
      GO TO 20

   10 ccum = 0.5D0*a
      cum = oma + ccum
   20 RETURN

      END


program test10
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
#if (_METIS==1)
 use modmetis,only:METIS_CTYPE_SHEM
#endif
 use modsparse
 implicit none
 integer(kind=int32)::nrow
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 integer(kind=int32)::i,j
 integer(kind=int32),allocatable::iarray(:,:)
 integer(kind=int32),allocatable::perm(:)
 real(kind=wp)::val
 real(kind=wp),allocatable::x(:),y(:)
 real(kind=wp),allocatable::xx(:)
 logical::lup=.false.
 type(coosparse)::coo
 type(crssparse)::crs
 type(crssparse)::crs1

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !COO UPPER
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(5,lupper=.true.)

 call coo%setsymmetric()

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 call coo%add(1,1,10._wp)
 call coo%add(2,2,10._wp)
 call coo%add(3,3,10._wp)
! call coo%add(4,4,1._wp)
 call coo%add(5,5,1._wp)
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR UPPER
 crs=coo

 call crs%printsquare()

 !perm=crs%getordering()
#if (_METIS==1)
 perm=crs%getordering(compress=1,ctype=METIS_CTYPE_SHEM)
#else
 perm=(/(i,i=1,crs%getdim(1))/)
#endif

 call crs%printstats()

 call crs%setpermutation(perm)
 call crs%printstats()

 allocate(x(crs%getdim(1)),y(crs%getdim(1)))
 do i=1,crs%getdim(1)
  y(i)=i
 enddo
 y(4)=0
 print*,'y=[',y,' ]'

 x=0._wp
 xx=x
 call coo%cg(xx,y)

 call crs%solve(x,y)
 print*,'xx ',xx
 print*,' x ',x

end program


program FizzBuzz
    implicit none
    character(len=4), dimension(100) :: fizzs = '', buzzs = ''
    integer :: i

    where (mod( (/ (i,i=1,100) /), 3) == 0) fizzs = 'Fizz'
    where (mod( (/ (i,i=1,100) /), 5) == 0) buzzs = 'Buzz'

    do i=1, 100
        if (fizzs(i)/='' .or. buzzs(i)/='') then
            print*, trim(fizzs(i))//trim(buzzs(i))
        else
            write(*,'(A,I0)') ' ', i
        end if
    end do

end program FizzBuzz


module matrix_mod
use iso_c_binding, only: c_int, c_float
implicit none
interface
subroutine print_mat(nrow_c, ncol_c, x) bind(c,name="print_mat_transpose")
import c_int, c_float
integer(kind=c_int), intent(in), value :: nrow_c, ncol_c
real(kind=c_float) , intent(in)        :: x(ncol_c,nrow_c)
end subroutine print_mat
!
function sum_mat(nrow_c,ncol_c,x) result(xsum) bind(c)
import c_int, c_float
integer(kind=c_int), intent(in), value :: nrow_c, ncol_c
real(kind=c_float) , intent(in)        :: x(ncol_c,nrow_c)
end function sum_mat
!
subroutine sum_cols(nrow_c,ncol_c,x,col_sums) bind(c,name="sum_rows")
import c_int, c_float
integer(kind=c_int), intent(in), value :: nrow_c, ncol_c
real(kind=c_float) , intent(in)        :: x(ncol_c,nrow_c)
real(kind=c_float) , intent(out)       :: col_sums(nrow_c)
end subroutine sum_cols
!
subroutine scale_mat(xscale, nrow_c, ncol_c, x) bind(c,name="scale_mat")
import c_int, c_float
real(kind=c_float) , intent(in), value :: xscale
integer(kind=c_int), intent(in), value :: nrow_c, ncol_c
real(kind=c_float) , intent(in)        :: x(ncol_c,nrow_c)
end subroutine scale_mat
!
end interface
!
contains
function column_sums(x) result(col_sums)
real(kind=c_float), intent(in) :: x(:,:)
real(kind=c_float) :: col_sums(size(x,2))
call sum_cols(size(x,2),size(x,1),x,col_sums)
end function column_sums
end module matrix_mod

program xxmat
use matrix_mod, only: c_float, print_mat, sum_mat, sum_cols, scale_mat, &
                      column_sums
implicit none
integer, parameter :: nr = 2, nc = 3
real(kind=c_float) :: x(nr,nc),row_sums(nr),col_sums(nc)
integer            :: ir,ic
character (len=20) :: fmt="(a,*(1x,f0.1))"
print*,"matrix"
do ir=1,nr
   do ic=1,nc
      x(ir,ic) = real(10*ir + ic, kind = c_float)
   end do
   print "(*(1x,f5.1))",x(ir,:)
end do
print "(/,a)", "calling print_mat"
call print_mat(nrow_c=nc, ncol_c=nr, x=x)
print*
print fmt,"sum_mat(nr,nc,x), sum(x) =",sum_mat(nr,nc,x),sum(x)
call sum_cols(nrow_c=nc, ncol_c=nr, x=x, col_sums=col_sums)
print fmt,"col_sums =",col_sums
print fmt,"col_sums =",column_sums(x)
print fmt,"sum(x,dim=1) =",sum(x,dim=1)
call scale_mat(xscale=10.0, nrow_c=nc, ncol_c=nr, x=x)
print "(/,a)","matrix after scaling:"
call print_mat(nrow_c=nc, ncol_c=nr, x=x)
end program xxmat
! Compile with
!   gcc -c -o sum_mat.o sum_mat.c
!   gfortran sum_mat.o xxmat.f90
! output:
!  matrix
!   11.0  12.0  13.0
!   21.0  22.0  23.0
!
! calling print_mat
!  11.000000 12.000000 13.000000
!  21.000000 22.000000 23.000000
!
! sum_mat(nr,nc,x), sum(x) = 102.0 102.0
! col_sums = 32.0 34.0 36.0
! col_sums = 32.0 34.0 36.0
! sum(x,dim=1) = 32.0 34.0 36.0
!
! matrix after scaling:
!  110.000000 120.000000 130.000000
!  210.000000 220.000000 230.000000


!==============================================================================!
  real function U_Plus_Log_Law(turb, y_plus)
!------------------------------------------------------------------------------!
!   Calculates U+ from log law.                                                !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Turb_Mod, only: Turb_Type, e_log, kappa
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type) :: turb
  real            :: y_plus
!==============================================================================!

  U_Plus_Log_Law = log( max(y_plus, 1.05) * e_log ) / kappa

  end function


MODULE PekRoot

  ! evaluates a particular branch of the square root that exposes leaky modes

  IMPLICIT NONE

  CONTAINS
    FUNCTION PekerisRoot( z )

      ! At one time, this was used to return the 'Pekeris branch cut'
      ! which is just a particular branch of the square root that
      ! exposes many 'leaky' or 'virtual' modes.

      ! The current version implements a particular branch that was convenient

      COMPLEX (KIND=8), INTENT(  IN ) :: z
      COMPLEX (KIND=8)                :: PekerisRoot

      IF ( REAL( z ) >= 0.0D0 ) THEN
         PekerisRoot = SQRT( z )
      ELSE
         PekerisRoot = ( 0.0D0, 1.0D0 ) * SQRT( -z )
      ENDIF

    END FUNCTION PekerisRoot
END MODULE PekRoot


! Mikayla Webber
! 4670 Numerical Analysis
! Homework

module secret

integer :: fcounter

end module secret

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

program WebberHomework
use secret
implicit none

real, allocatable :: y(:), t(:)
real :: yo, tmax, h, k1, k2, y1, f
integer :: ni, i

print*, 'Enter yo, tmax, ni'
read*, yo, tmax, ni
h = tmax/ni
print*, 'This gives stepsize h=', h
allocate(t(0:ni), y(0:ni))

t(0) = 0
t(1) = h
y(0) = 1
k1 = -16*h**3
y1 = y(0) + h/2 *(k1 + k2)
do i = 2, ni
  t(i) = i*h
  y(i) = y(i-1) + (h/2)*(3*f(t(i-1), y(i - 1))- f(t(i-2), y(i-2)))
end do

stop
end program WebberHomework

!-----------------------------------------------------------------------------------------------------
real function f(t,y)
  real :: t,y

  f = -16*t**3*y**2

  return
end

4670 Numerical Analysis/Class Examples/DifferentialEquations.f90


      FUNCTION bessy(n,x)
      INTEGER n
      REAL bessy,x
CU    USES bessy0,bessy1
      INTEGER j
      REAL by,bym,byp,tox,bessy0,bessy1
      if(n.lt.2)pause 'bad argument n in bessy'
      tox=2./x
      by=bessy1(x)
      bym=bessy0(x)
      do 11 j=1,n-1
        byp=j*tox*by-bym
        bym=by
        by=byp
11    continue
      bessy=by
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/bessy.for


! Riemann solver for the variable speed limit LWR traffic model

! q_t + (u_max(x,t) q(1-q))_x = 0

! Here the speed limit u_max (stored in aux(1,i) may vary with x and t.

! waves: 1
! equations: 1
! aux fields: 1

! Conserved quantities:
!       1 q

! Auxiliary variables:
!       1 u_max

! See http://www.clawpack.org/riemann.html for a detailed explanation
! of the Riemann solver API.

subroutine rp1(maxm,num_eqn,num_waves,num_aux,num_ghost,num_cells, &
               ql,qr,auxl,auxr,wave,s,amdq,apdq)
    implicit none
    ! Inputs
    integer, intent(in) :: maxm, num_eqn, num_waves, num_aux, num_ghost, num_cells
    double precision, intent(in), dimension(num_eqn, 1-num_ghost:maxm+num_ghost) :: ql,qr
    double precision, intent(in), dimension(num_aux, 1-num_ghost:maxm+num_ghost) :: auxl,auxr
    ! Outputs
    double precision, intent(out) :: s(num_waves,1-num_ghost:num_cells+num_ghost)
    double precision, intent(out) :: wave(num_eqn,num_waves,1-num_ghost:num_cells+num_ghost)
    double precision, intent(out), dimension(num_eqn, 1-num_ghost:maxm+num_ghost) :: amdq,apdq
    ! Locals
    double precision :: f_l, f_r, s_l, s_r, f0, q_l, q_r, v_l, v_r
    integer :: i

    do i = 2-num_ghost, num_cells+num_ghost
        q_r = ql(1,i)
        q_l = qr(1,i-1)
        v_r = auxl(1,i)
        v_l = auxr(1,i-1)

        ! compute characteristic speed in each cell:
        s_l = v_l*(1.d0 - 2.d0*q_l)
        s_r = v_r*(1.d0 - 2.d0*q_r)

        ! compute flux in each cell and flux difference:
        f_l = v_l*q_l*(1.d0 - q_l)
        f_r = v_r*q_r*(1.d0 - q_r)

        ! This seems to work well even though there can be
        ! a stationary jump in q.
        wave(1,1,i) = q_r - q_l
        s(1,i) = 0.5d0*(s_l + s_r)

        if ((f_l .ge. 0.25d0*v_r) .and. (s_r .gt. 0.d0)) then
            ! left-going shock, right-going rarefaction
            f0 = 0.25d0*v_r
        elseif ((f_r .ge. 0.25d0*v_l) .and. (s_l .lt. 0.d0)) then
            ! right-going shock, left-going rarefaction
            f0 = 0.25d0*v_l
        elseif ((s_r .le. 0.d0) .and. (f_l .gt. f_r)) then
            ! left-going shock
            f0 = f_r
        elseif ((s_l .ge. 0.d0) .and. (f_r .gt. f_l)) then
            ! right-going shock
            f0 = f_l
        elseif ((s_l .le. 0.d0) .and. (s_r .ge. 0.d0)) then
            ! Transonic rarefaction
            if (v_r .le. v_l) then
                f0 = 0.25d0*v_r
            else
                f0 = 0.25d0*v_l
            endif
        elseif (f_l .le. f_r) then
            ! left-going rarefaction
            f0 = f_r
        else
            ! right-going rarefaction
            f0 = f_l
        endif
        amdq(1,i) = f0 - f_l
        apdq(1,i) = f_r - f0

    enddo
    return
end subroutine rp1


program matMulFortran
  integer i,j,k
  integer, parameter :: n=1000
  real*8 :: a(n,n), b(n,n), c(n,n)
  do i=1,n
    do j=1,n
      a(i,j) = i*j
      b(i,j) = i-j
    enddo
  enddo
  print *, "Data initialized"
  do i=1,n
    do j=1,n
      c(i,j) = 0.d0
      do k=1,n
        c(i,j)=c(i,j)+a(i,k)*b(k,j)
      enddo
    enddo
  enddo

  ! CHECK FOR 3x3 MATRIX
  ! do i=1,n
  !   print *, c(i,1:3)
  ! enddo

end program matMulFortran


C$Procedure                     PI ( Value of pi )

      DOUBLE PRECISION FUNCTION PI ( )

C$ Abstract
C
C     Return the value of pi (the ratio of the circumference of
C     a circle to its diameter).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONSTANTS
C
C$ Declarations
C
C     None.
C
C$ Brief_I/O
C
C     The function returns the value of pi.
C
C$ Detailed_Input
C
C     None.
C
C$ Detailed_Output
C
C     The function returns the value of pi (the ratio of a circle's
C     circumference to its diameter), determined by the ACOS function.
C     That is,
C
C           PI = ACOS ( -1.D0 )
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The first time the function is referenced, the value is computed
C     as shown above. The value is saved, and returned directly upon
C     subsequent reference.
C
C$ Examples
C
C     The code fragment below illustrates the use of PI.
C
C        C
C        C     Compute the polar radius,
C        C
C        C                 p
C        C          ----------------
C        C          1 + e cos(theta)
C        C
C        C     at evenly spaced values of the polar angle, theta.
C        C
C              DELTA = PI() / N
C
C              DO I = 0, N
C                 R(I) = P / (1.D0 + ECC * COS(I*DELTA))
C              END DO
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C     I.M. Underwood  (JPL)
C
C$ Version
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU)
C
C-&

C$ Index_Entries
C
C     value of pi
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      VALUE
      SAVE                  VALUE

C
C     Initial values
C
      DATA                  VALUE      / 0.D0 /

C
C     What is there to say?
C
      IF ( VALUE .EQ. 0.D0 ) THEN
         VALUE = ACOS ( -1.D0 )
      END IF

      PI = VALUE

      RETURN
      END


PROGRAM F096

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, DIMENSION(50, 9, 9) :: SUDOKU

    INTEGER :: SUM_VAL   = 0
    INTEGER :: INDEX_VAL = 0
    INTEGER :: SUB_INDEX = 1

    INTEGER :: I, I2, J, J2, K, L, PUZZLE

    LOGICAL :: DUPLICATE_FOUND

    LOGICAL, DIMENSION(9, 9, 9)   :: DIGIT
    LOGICAL, DIMENSION(9, 9)      :: IS_FIXED_CELL

    CHARACTER (LEN=30), PARAMETER :: FILENAME = "problems/096/p096_sudoku.txt"
    CHARACTER (LEN=30)            :: NUM_STR

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    DO
        READ(2, *, END=10) NUM_STR

        IF (NUM_STR(1:1) < '0' .OR. NUM_STR(1:1) > '9') THEN
            SUB_INDEX = 1
            INDEX_VAL = INDEX_VAL + 1
            CYCLE

        END IF

        DO I = 1, 9
            SUDOKU(INDEX_VAL, SUB_INDEX, I) = IACHAR(NUM_STR(I:I)) - IACHAR('0')
        END DO
        SUB_INDEX = SUB_INDEX + 1
    END DO

    10 CLOSE(2)

    DO PUZZLE = 1, 50

        IS_FIXED_CELL = .FALSE.

        DO I = 1, 9
            DO J = 1, 9
                IF (SUDOKU(PUZZLE, I, J) /= 0) IS_FIXED_CELL(I, J) = .TRUE.
            END DO
        END DO

        DIGIT = .FALSE.

        I = 1
        DO WHILE (I <= 9)
            J = 1
            DO WHILE (J <= 9)

                IF (IS_FIXED_CELL(I, J)) THEN
                    J = J + 1
                    CYCLE
                END IF

                I2 = (INT((I - 1) / 3) * 3) + 1
                J2 = (INT((J - 1) / 3) * 3) + 1

                DUPLICATE_FOUND = .TRUE.

                IF (.NOT. DIGIT(I, J, 1)  .OR. .NOT. DIGIT(I, J, 2)            &
               .OR. .NOT. DIGIT(I, J, 3)  .OR. .NOT. DIGIT(I, J, 4)            &
               .OR. .NOT. DIGIT(I, J, 5)  .OR. .NOT. DIGIT(I, J, 6)            &
               .OR. .NOT. DIGIT(I, J, 7)  .OR. .NOT. DIGIT(I, J, 8)            &
               .OR. .NOT. DIGIT(I, J, 9)) THEN

                    DO K = 1, 9

                        IF (DIGIT(I, J, K)) CYCLE

                        DUPLICATE_FOUND = .FALSE.

                        DO L = 1, 9
                            IF (L /= I) THEN
                                IF (SUDOKU(PUZZLE, L, J) == K) THEN
                                    DUPLICATE_FOUND = .TRUE.
                                    EXIT
                                END IF
                            END IF
                            IF (L /= J) THEN
                                IF (SUDOKU(PUZZLE, I, L) == K) THEN
                                    DUPLICATE_FOUND = .TRUE.
                                    EXIT
                                END IF
                            END IF
                        END DO

                        IF (.NOT. DUPLICATE_FOUND) THEN
                            IF ((SUDOKU(PUZZLE, I2,     J2)     == K)          &
                           .OR. (SUDOKU(PUZZLE, I2,     J2 + 1) == K)          &
                           .OR. (SUDOKU(PUZZLE, I2,     J2 + 2) == K)          &
                           .OR. (SUDOKU(PUZZLE, I2 + 1, J2)     == K)          &
                           .OR. (SUDOKU(PUZZLE, I2 + 1, J2 + 1) == K)          &
                           .OR. (SUDOKU(PUZZLE, I2 + 1, J2 + 2) == K)          &
                           .OR. (SUDOKU(PUZZLE, I2 + 2, J2)     == K)          &
                           .OR. (SUDOKU(PUZZLE, I2 + 2, J2 + 1) == K)          &
                           .OR. (SUDOKU(PUZZLE, I2 + 2, J2 + 2) == K)) THEN

                                DUPLICATE_FOUND = .TRUE.

                            END IF
                        END IF

                        IF (.NOT. DUPLICATE_FOUND) THEN
                            DIGIT(I, J, K)  = .TRUE.
                            SUDOKU(PUZZLE, I, J) = K
                            EXIT
                        END IF

                    END DO

                END IF

                IF (DUPLICATE_FOUND) THEN

                    DIGIT(I, J, 1:9) = .FALSE.
                    SUDOKU(PUZZLE, I, J) = 0

                    J = J - 1
                    IF (J == 0) THEN
                        J = 9
                        I = I - 1
                    END IF

                    DO WHILE (IS_FIXED_CELL(I, J))
                        J = J - 1
                        IF (J == 0) THEN
                            J = 9
                            I = I - 1
                        END IF
                    END DO

                ELSE
                    J = J + 1
                END IF

            END DO
            I = I + 1
        END DO
        SUM_VAL = SUM_VAL + (SUDOKU(PUZZLE, 1, 1) * 100) +                     &
                            (SUDOKU(PUZZLE, 1, 2) * 10)  +                     &
                            (SUDOKU(PUZZLE, 1, 3))
    END DO

    PRINT ('(I0)'), SUM_VAL

END PROGRAM F096


       integer function LOCALINDEX(ig,nx,npx,pex)
!
!   INPUT :
!           ig  global index of the x dimension of array element
!
!           nx  x dimension of the global array
!
!           npx  number of processor in the x dimension of the processors grid
!
!           pex  x index of the local processor in the processor grid
!                (starting from zero)
!
!   OUTPUT :
!
!           localindex  index of the element in the local block
!

       IMPLICIT NONE

       INTEGER il,ig,nx,npx,pex,r,q

       Q = INT(nx/npx)
       R = MOD(nx,npx)
       IF((pex+1).LE.R) THEN
         localindex = ig - (Q+1)*pex
       ELSE
         localindex = ig - Q*pex + R
       end if

       return
       end


      PROGRAM xlubksb
C     driver for routine lubksb
      INTEGER NP
      PARAMETER (NP=20)
      REAL p,a(NP,NP),b(NP,NP),c(NP,NP),x(NP)
      INTEGER j,k,l,m,n,indx(NP)
      CHARACTER txt*3
      open(7,file='MATRX1.DAT',status='old')
      read(7,*)
10    read(7,*)
      read(7,*) n,m
      read(7,*)
      read(7,*) ((a(k,l), l=1,n), k=1,n)
      read(7,*)
      read(7,*) ((b(k,l), k=1,n), l=1,m)
C     save matrix a for later testing
      do 12 l=1,n
        do 11 k=1,n
          c(k,l)=a(k,l)
11      continue
12    continue
C     do LU decomposition
      call ludcmp(c,n,NP,indx,p)
C     solve equations for each right-hand vector
      do 16 k=1,m
        do 13 l=1,n
          x(l)=b(l,k)
13      continue
        call lubksb(c,n,NP,indx,x)
C     test results with original matrix
        write(*,*) 'Right-hand side vector:'
        write(*,'(1x,6f12.6)') (b(l,k), l=1,n)
        write(*,*) 'Result of matrix applied to sol''n vector'
        do 15 l=1,n
          b(l,k)=0.0
          do 14 j=1,n
            b(l,k)=b(l,k)+a(l,j)*x(j)
14        continue
15      continue
        write(*,'(1x,6f12.6)') (b(l,k), l=1,n)
        write(*,*) '***********************************'
16    continue
      write(*,*) 'Press RETURN for next problem:'
      read(*,*)
      read(7,'(a3)') txt
      if (txt.ne.'END') goto 10
      close(7)
      END

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


module n_opt
  implicit none
  public::nOpt

contains

  recursive logical function nOpt(n,topOpt,is) result (successfulOpt)
    use incidence_structure
    implicit none
    type(IncidenceStructure) is
    integer n,row,col1,col2,topOpt
    integer col1_delta, col2_delta

    logical sumTotal_low, sumTotal_high
    logical sumInRow_low, sumInRow_high

    successfulOpt=.false.

    ! Skip criteria for the n-opt:
    ! We reached the end of the n-opt descent, return
    if(n<1) return
    ! For each row try exchanging each two opposite-state cells
    do row=1,is%v
       do col1=1,is%b - 1
          do col2=col1 + 1,is%b
             ! Do not exchange cells with the same state
             if(dormant(is,row,col1).and.dormant(is,row,col2)) cycle
             if(active(is,row,col1).and.active(is,row,col2)) cycle

             if(abs(is%sum_in_col(col1)-is%k) > n) cycle
             if(abs(is%sum_in_col(col2)-is%k) > n) cycle

             ! Exchange the cells' state
             call flip(is,row,col1)
             call flip(is,row,col2)

             ! Try testing for BIBD
             if(isBIBD(is)) then
                print *, topOpt, "-opt yielded a BIBD"
                successfulOpt=.true.
                return
             ! Else try descending
             else if(nOpt(n-1,topOpt,is)) then
                successfulOpt=.true.
                return
                ! If the descent failed, flip the cell back and continue
             else
                call flip(is,row,col1)
                call flip(is,row,col2)
             endif
          enddo
       enddo
    enddo
    ! Upon reaching here we return .FALSE.
    return
  end function nOpt

end module n_opt


SUBROUTINE SPOTRF_F95( A, UPLO, RCOND, NORM, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: POTRF_F77 => LA_POTRF, LANSY_F77 => LA_LANSY, &
                                  POCON_F77 => LA_POCON
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. CHARACTER ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM, UPLO
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL  :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(INOUT) :: A(:,:)
!-----------------------------------------------------------------
!
! Purpose
! =======
!
! LA_POTRF computes the Cholesky factorization of a real symmetric or
! complex Hermitian positive definite matrix A.
!
! The factorization has the form
!    A = U**H * U,  if UPLO = 'U', or
!    A = L * L**H,  if UPLO = 'L',
! where U is an upper triangular matrix and L is lower triangular.
!
! This is the block version of the algorithm, calling Level 3 BLAS.
!
! LA_POTRF optionally estimates the reciprocal of the condition number
! (in the 1-norm) of a real symmetric or complex Hermitian positive
! definite matrix A.
! An estimate is obtained for norm(inv(A)), and the reciprocal of the
! condition number is computed as RCOND = 1 / (norm(A) * norm(inv(A))).
!
! =======
!
!    SUBROUTINE LA_POTRF( A, UPLO, RCOND, NORM, INFO )
!       <type>(<wp>), INTENT(INOUT) :: A(:,:)
!       CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!       REAL(<wp>), INTENT(OUT), OPTIONAL :: RCOND
!       CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM
!       INTEGER, INTENT(OUT), OPTIONAL :: INFO
!    where
!       <type> ::= REAL | COMPLEX
!       <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Defaults
! ========
!
! 1. If UPLO is not present then UPLO = 'U' is assumed.
!
! Arguments
! =========
!
! A       (input/output) either REAL or COMPLEX square array,
!         shape (:,:), size(A,1) == size(A,2) >= 0.
!         On entry, the symmetric (Hermitian) matrix A.
!            If UPLO = 'U', the upper triangular part of A contains
!               the upper triangular part of the matrix A, and the
!               strictly lower triangular part of A is not referenced.
!            If UPLO = 'L', the lower triangular part of A contains
!               the lower triangular part of the matrix A, and the
!               strictly upper triangular part of A is not referenced.
!         On exit, if INFO = 0, the factor U or L from the Cholesky
!            factorization A = U**H*U or A = L*L**H.
!
! UPLO    Optional, (input) CHARACTER*1
!         If UPLO is present then:
!            = 'U':  Upper triangle of A is stored;
!            = 'L':  Lower triangle of A is stored.
!         otherwise UPLO = 'U' is assumed.
!
! RCOND   Optional (output) REAL
!         The reciprocal of the condition number of the matrix A
!         computed as RCOND = 1/(norm(A) * norm(inv(A))).
! NORM    Optional (input) CHARACTER*1
!         Specifies whether the 1-norm condition number or the
!         infinity-norm condition number is required:
!           If NORM is present then:
!              = '1', 'O' or 'o': 1-norm;
!              = 'I' or 'i': infinity-norm.
!           otherwise NORM = '1' is used.
!
! INFO    Optional, (output) INTEGER
!         If INFO is present:
!            = 0: successful exit
!            < 0: if INFO = -i, the i-th argument had an illegal value
!            > 0: if INFO = i, the leading minor of order i is not
!               positive definite, and the factorization could not be
!               completed.
!         If INFO is not present and an error occurs, then the program
!            is terminated with an error message.
!
! --------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_POTRF'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LNORM, LUPLO
   INTEGER :: LINFO, N, ISTAT, ISTAT1, LD
   REAL(WP) :: ANORM
!  .. LOCAL POINTERS ..
   INTEGER, POINTER :: IWORK(:)
   REAL(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, MAX
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; N = SIZE(A,1); LD = MAX(1,N); ISTAT = 0
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(NORM) ) THEN; LNORM = NORM; ELSE; LNORM = '1'; END IF
!  .. TEST THE ARGUMENTS
   IF( SIZE( A, 2 ) /= N .AND. N < 0 )THEN; LINFO = -1
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -2
   ELSE IF( ( .NOT.PRESENT(RCOND) .AND. PRESENT(NORM) ) .OR. &
            ( .NOT.LSAME(LNORM,'I') .AND. .NOT.LSAME(LNORM,'O') &
              .AND. LNORM /= '1' ) ) THEN; LINFO = -4
   ELSE IF(  N > 0 )THEN
      IF( PRESENT(RCOND) ) THEN
!     .. COMPUTE THE NORM OF THE MATRIX A
         ALLOCATE(WORK(N), STAT=ISTAT)
         IF( ISTAT == 0 )THEN; ANORM = LANSY_F77( LNORM, LUPLO, LD, A, N, WORK )
         ELSE; LINFO = -100; END IF
         DEALLOCATE(WORK, STAT=ISTAT1)
      END IF
!
      IF( LINFO == 0 ) THEN
!     .. COMPUTE THE CHOLESKY FACTORS OF THE MATRIX A
         CALL POTRF_F77( LUPLO, N, A, LD, LINFO )
!
         IF( PRESENT(RCOND) .AND. LINFO == 0 ) THEN
!        .. COMPUTE THE RECIPROCAL OF THE CONDITION NUMBER OF A
            IF( ANORM == 0.0_WP )THEN; RCOND = 0.0_WP
            ELSE; ALLOCATE(WORK(3*N), IWORK(N), STAT=ISTAT)
               IF( ISTAT == 0 )THEN
                  CALL POCON_F77( LUPLO, N, A, LD, ANORM, RCOND, &
                                  WORK, IWORK, LINFO )
               ELSE; LINFO = -100; END IF
               DEALLOCATE(WORK, IWORK, STAT=ISTAT1)
            END IF
         END IF
      END IF
   ELSE IF( PRESENT(RCOND) ) THEN; RCOND = 1.0_WP; ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE SPOTRF_F95


!*****************************************************************************************
!>
!  This program tests the ability of [[chkder]] to detect
!  inconsistencies between functions and their first derivatives.
!  fourteen test function vectors and jacobians are used. eleven of
!  the tests are false(f), i.e. there are inconsistencies between
!  the function vectors and the corresponding jacobians. three of
!  the tests are true(t), i.e. there are no inconsistencies. the
!  driver reads in data, calls chkder and prints out information
!  required by and received from chkder.

program test_chkder

    use minpack_module, only: wp, dpmpar, chkder
    use iso_fortran_env, only: nwrite => output_unit

    implicit none

    ! originally from file23
    integer,parameter :: ncases = 14
    integer,dimension(ncases),parameter :: nprobs  = [1,2,3,4,5,6,7,8,9,10,11,12,13,14]
    integer,dimension(ncases),parameter :: ns      = [2,4,2,4,3,9,7,10,10,10,10,10,10,10]

    integer :: i, ldfjac, lnp, mode, n, nprob, icase
    real(wp) :: cp
    integer,dimension(ncases) :: na, np
    real(wp),dimension(ncases) :: errmax, errmin
    real(wp),dimension(:),allocatable :: diff, err, fvec1, fvec2, x1, x2
    real(wp),dimension(:,:),allocatable :: fjac

    logical,dimension(ncases),parameter :: a = &
            [.false., .false., .false., .true., .false., .false., .false., &
             .true., .false., .false., .false., .false., .true., .false.]
    real(wp), parameter :: one = 1.0_wp
    real(wp), parameter :: tol = sqrt(dpmpar(1)) !! abstol for matching previously generated solutions
    real(wp), parameter :: solution_reltol = 1.0e-4_wp !! reltol for matching previously generated solutions

    integer,dimension(ncases),parameter :: info_original = 1 ! not used here

    cp = 1.23e-1_wp

    do icase = 1, ncases+1

        if (icase == ncases+1) then
            write (nwrite, '(a,i3,a/)') '1SUMMARY OF ', lnp, ' TESTS OF CHKDER'
            write (nwrite, '(a/)')      ' NPROB   N    STATUS     ERRMIN         ERRMAX'
            do i = 1, lnp
                write (nwrite, '(i4, i6, 6x, l1, 3x, 2d15.7)') np(i), na(i), a(i), errmin(i), errmax(i)
            end do
            stop
        else
            nprob = nprobs(icase)
            n = ns(icase)
            ldfjac = n

            if (allocated(diff)) deallocate(diff)
            if (allocated(err)) deallocate(err)
            if (allocated(fjac)) deallocate(fjac)
            if (allocated(fvec1)) deallocate(fvec1)
            if (allocated(fvec2)) deallocate(fvec2)
            if (allocated(x1)) deallocate(x1)
            if (allocated(x2)) deallocate(x2)
            allocate(diff(n))
            allocate(err(n))
            allocate(fjac(n, n))
            allocate(fvec1(n))
            allocate(fvec2(n))
            allocate(x1(n))
            allocate(x2(n))

            call initpt(n, x1, nprob, one)
            do i = 1, n
                x1(i) = x1(i) + cp
                cp = -cp
            end do
            write (nwrite, '(///5x, a, i5, 5x, a, i5, 2x, a, l1)') ' PROBLEM', nprob, ' WITH DIMENSION', n, ' IS  ', a(nprob)
            mode = 1
            call chkder(n, n, x1, fvec1, fjac, ldfjac, x2, fvec2, mode, err)
            mode = 2
            call vecfcn(n, x1, fvec1, nprob)
            call errjac(n, x1, fjac, ldfjac, nprob)
            call vecfcn(n, x2, fvec2, nprob)
            call chkder(n, n, x1, fvec1, fjac, ldfjac, x2, fvec2, mode, err)
            errmin(nprob) = err(1)
            errmax(nprob) = err(1)
            do i = 1, n
                diff(i) = fvec2(i) - fvec1(i)
                if (errmin(nprob) > err(i)) errmin(nprob) = err(i)
                if (errmax(nprob) < err(i)) errmax(nprob) = err(i)
            end do
            np(nprob) = nprob
            lnp = nprob
            na(nprob) = n
            write (nwrite, '(//5x, a//(5x, 5d15.7))') ' FIRST FUNCTION VECTOR   ', (fvec1(i), i=1, n)
            write (nwrite, '(//5x, a//(5x, 5d15.7))') ' FUNCTION DIFFERENCE VECTOR', (diff(i), i=1, n)
            write (nwrite, '(//5x, a//(5x, 5d15.7))') ' ERROR VECTOR', (err(i), i=1, n)
            call compare_solutions(nprob, diff, solution_reltol, tol)

        end if

    end do

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

!*****************************************************************************************
!>
!  Compare with previously generated solutions.

    subroutine compare_solutions(ic, x, reltol, abstol)

    implicit none

    integer,intent(in) :: ic !! problem number (index is `solution` vector)
    real(wp),dimension(:),intent(in) :: x !! computed `x` vector from the method
    real(wp),intent(in) :: reltol !! relative tolerance for `x` to pass
    real(wp),intent(in) :: abstol !! absolute tolerance for `x` to pass

    real(wp),dimension(size(x)) :: diff, absdiff, reldiff

    if (info_original(ic)<5) then    ! ignore any where the original minpack failed
        diff = solution(ic) - x
        absdiff = abs(diff)
        if (any(absdiff>abstol)) then ! first do an absolute diff
            ! also do a rel diff if the abs diff fails (also protect for divide by zero)
            reldiff = absdiff
            where (solution(ic) /= 0.0_wp) reldiff = absdiff / abs(solution(ic))
            if (any(reldiff > reltol)) then
                write(nwrite,'(A)') 'Failed case'
                write(nwrite, '(//5x, a//(5x, 5d15.7))') 'Expected x: ', solution(ic)
                write(nwrite, '(/5x, a//(5x, 5d15.7))')  'Computed x: ', x
                write(nwrite, '(/5x, a//(5x, 5d15.7))')  'absdiff: ', absdiff
                write(nwrite, '(/5x, a//(5x, 5d15.7))')  'reldiff: ', reldiff
                error stop ! test failed
            end if
        end if
    end if

    end subroutine compare_solutions
!*****************************************************************************************

!*****************************************************************************************
!>
!  Replaced statement function in original code.

    pure elemental function dfloat(i) result(f)
        implicit none
        integer, intent(in) :: i
        real(wp) :: f
        f = real(i, wp)
    end function dfloat
!*****************************************************************************************

!*****************************************************************************************
!>
!  Get expected `diff` vectors for each case.

    pure function solution(nprob) result(x)

        implicit none

        integer,intent(in) :: nprob
        real(wp),dimension(:),allocatable :: x

        select case (nprob)
        case(1); x = [-0.1604855093262358E-07_wp,0.4763689633868751E-06_wp]
        case(2); x = [0.2138763655068487E-06_wp,-0.2512328678427878E-07_wp,-0.3578105500778861E-07_wp,&
                      0.4754114257821129E-06_wp]
        case(3); x = [0.3214806338291964E-04_wp,-0.7057517459330143E-08_wp]
        case(4); x = [0.2322078535144101E-03_wp,0.5335169362297165E-04_wp,0.2089913541567512E-03_wp,&
                      0.4808346034224087E-04_wp]
        case(5); x = [0.1832842144722235E-07_wp,-0.1319622122686326E-06_wp,0.1832842821958280E-08_wp]
        case(6); x = [0.4515008482641747E-06_wp,0.8252608125758343E-06_wp,0.1047075926408070E-05_wp,&
                      0.1220878203866960E-05_wp,0.1363612746274612E-05_wp,0.1485299534920159E-05_wp,&
                      0.1592014982065848E-05_wp,0.1687697022134671E-05_wp,0.1775024010441939E-05_wp]
        case(7); x = [0.1542483058641908E-07_wp,0.2060287401794980E-07_wp,0.2376945576476608E-07_wp,&
                      0.5349154558187408E-07_wp,0.9704076181504817E-07_wp,0.1576633008593120E-06_wp,&
                      0.2112184365188341E-06_wp]
        case(8); x = [0.8012354335562577E-07_wp,0.8378922800034161E-07_wp,0.8012354335562577E-07_wp,&
                      0.8378922800034161E-07_wp,0.8012354335562577E-07_wp,0.8378922800034161E-07_wp,&
                      0.8012354335562577E-07_wp,0.8378922800034161E-07_wp,0.8012354335562577E-07_wp,&
                      0.1065043608861060E-09_wp]
        case(9); x = [0.5774599409757997E-08_wp,-0.7078711450336783E-08_wp,0.7631400400498478E-08_wp,&
                      -0.7053519379685014E-08_wp,0.7658129463905539E-08_wp,-0.7038501670386665E-08_wp,&
                      0.7685261871337445E-08_wp,-0.7047089523037897E-08_wp,0.6495039228671118E-08_wp,&
                      -0.2818530409065545E-08_wp]
        case(10);x = [0.3294705064327275E-08_wp,0.8148107188965525E-09_wp,0.5413627796047038E-08_wp,&
                      0.2381044444943470E-08_wp,0.6401980501280491E-08_wp,0.2764786941056308E-08_wp,&
                      0.6166095051218790E-08_wp,0.1882141179021524E-08_wp,0.4645276802106579E-08_wp,&
                      0.9133731548871538E-09_wp]
        case(11);x = [0.3284536753689338E-08_wp,0.1864164600462459E-08_wp,0.3268772807984988E-08_wp,&
                      0.3333951337225471E-08_wp,0.3253008529213730E-08_wp,0.4803738740122299E-08_wp,&
                      0.3237243362264053E-08_wp,0.6273523034394657E-08_wp,0.3221478195314376E-08_wp,&
                      0.7743309993202274E-08_wp]
        case(12);x = [0.2249654149636626E-02_wp,0.4499298869632185E-02_wp,0.6748936313670129E-02_wp,&
                      0.8998581033665687E-02_wp,0.1124821836128831E-01_wp,0.1349786319769919E-01_wp,&
                      0.1574750046711415E-01_wp,0.1799714541994035E-01_wp,0.2024678350426257E-01_wp,&
                      0.2249642740935087E-01_wp]
        case(13);x = [0.9923452193305593E-07_wp,0.3484660204833290E-07_wp,0.8616620350565540E-07_wp,&
                      0.3484660204833290E-07_wp,0.8616620350565540E-07_wp,0.3484660204833290E-07_wp,&
                      0.8616620350565540E-07_wp,0.3484660204833290E-07_wp,0.8616620350565540E-07_wp,&
                      0.6831460996892247E-07_wp]
        case(14);x = [0.3598775801805232E-06_wp,0.2186061109910042E-06_wp,0.3905816612359558E-06_wp,&
                      0.2493101911582585E-06_wp,0.4212857422913885E-06_wp,0.2800142722136911E-06_wp,&
                      0.4311392522993174E-06_wp,0.2800142722136911E-06_wp,0.4311392522993174E-06_wp,&
                      0.2591637029425442E-06_wp]
        case default
            error stop 'invalid case'
        end select

    end function solution
!*****************************************************************************************

!*****************************************************************************************
!>
!  This subroutine is derived from [[vecjac]] which defines the
!  jacobian matrices of fourteen test functions. the problem
!  dimensions are as described in the prologue comments of vecfcn.
!  various errors are deliberately introduced to provide a test
!  for chkder.

    subroutine errjac(n, x, Fjac, Ldfjac, Nprob)
        implicit none

        integer, intent(in) :: n !! a positive integer variable.
        integer, intent(in) :: Ldfjac !! a positive integer variable not less than n
                                      !! which specifies the leading dimension of the array fjac.
        integer, intent(in) :: Nprob !! a positive integer variable which defines the
                                     !! number of the problem. nprob must not exceed 14.
        real(wp), intent(in) :: x(n) !! an array of length n.
        real(wp), intent(out) :: Fjac(Ldfjac, n) !! an n by n array. on output fjac contains the
                                                 !! jacobian matrix, with various errors deliberately
                                                 !! introduced, of the nprob function evaluated at x.

        real(wp),parameter :: zero = 0.0e0_wp
        real(wp),parameter :: one = 1.0e0_wp
        real(wp),parameter :: two = 2.0e0_wp
        real(wp),parameter :: three = 3.0e0_wp
        real(wp),parameter :: four = 4.0e0_wp
        real(wp),parameter :: five = 5.0e0_wp
        real(wp),parameter :: six = 6.0e0_wp
        real(wp),parameter :: eight = 8.0e0_wp
        real(wp),parameter :: ten = 1.0e1_wp
        real(wp),parameter :: fiftn = 1.5e1_wp
        real(wp),parameter :: twenty = 2.0e1_wp
        real(wp),parameter :: hundrd = 1.0e2_wp
        real(wp),parameter :: c1 = 1.0e4_wp
        real(wp),parameter :: c3 = 2.0e2_wp
        real(wp),parameter :: c4 = 2.02e1_wp
        real(wp),parameter :: c5 = 1.98e1_wp
        real(wp),parameter :: c6 = 1.8e2_wp
        real(wp),parameter :: c9 = 2.9e1_wp
        real(wp),parameter :: tpi = eight*atan(one)

        integer :: i, j, k, k1, k2, ml, mu
        real(wp) :: h, prod, sum, sum1, sum2, temp, temp1, temp2, &
                    temp3, temp4, ti, tj, tk

        Fjac(1:n,1:n) = zero

        ! jacobian routine selector.

        select case (nprob)
        case (2)
            ! powell singular function with sign reversal affecting element
            ! (3,3).
            do k = 1, 4
                do j = 1, 4
                    fjac(k, j) = zero
                end do
            end do
            fjac(1, 1) = one
            fjac(1, 2) = ten
            fjac(2, 3) = sqrt(five)
            fjac(2, 4) = -fjac(2, 3)
            fjac(3, 2) = two*(x(2) - two*x(3))
            fjac(3, 3) = two*fjac(3, 2)
            fjac(4, 1) = two*sqrt(ten)*(x(1) - x(4))
            fjac(4, 4) = -fjac(4, 1)
        case (3)
            ! powell badly scaled function with the sign of the jacobian
            ! reversed.
            fjac(1, 1) = -c1*x(2)
            fjac(1, 2) = -c1*x(1)
            fjac(2, 1) = exp(-x(1))
            fjac(2, 2) = exp(-x(2))
        case (4)
            ! wood function without error.
            do k = 1, 4
                do j = 1, 4
                    fjac(k, j) = zero
                end do
            end do
            temp1 = x(2) - three*x(1)**2
            temp2 = x(4) - three*x(3)**2
            fjac(1, 1) = -c3*temp1 + one
            fjac(1, 2) = -c3*x(1)
            fjac(2, 1) = -two*c3*x(1)
            fjac(2, 2) = c3 + c4
            fjac(2, 4) = c5
            fjac(3, 3) = -c6*temp2 + one
            fjac(3, 4) = -c6*x(3)
            fjac(4, 2) = c5
            fjac(4, 3) = -two*c6*x(3)
            fjac(4, 4) = c6 + c4
        case (5)
            ! helical valley function with multiplicative error affecting
            ! elements (2,1) and (2,2).
            temp = x(1)**2 + x(2)**2
            temp1 = tpi*temp
            temp2 = sqrt(temp)
            fjac(1, 1) = hundrd*x(2)/temp1
            fjac(1, 2) = -hundrd*x(1)/temp1
            fjac(1, 3) = ten
            fjac(2, 1) = five*x(1)/temp2
            fjac(2, 2) = five*x(2)/temp2
            fjac(2, 3) = zero
            fjac(3, 1) = zero
            fjac(3, 2) = zero
            fjac(3, 3) = one
        case (6)
            ! watson function with sign reversals affecting the computation of
            ! temp1.
            do k = 1, n
                do j = k, n
                    fjac(k, j) = zero
                end do
            end do
            do i = 1, 29
                ti = dfloat(i)/c9
                sum1 = zero
                temp = one
                do j = 2, n
                    sum1 = sum1 + dfloat(j - 1)*temp*x(j)
                    temp = ti*temp
                end do
                sum2 = zero
                temp = one
                do j = 1, n
                    sum2 = sum2 + temp*x(j)
                    temp = ti*temp
                end do
                temp1 = two*(sum1 + sum2**2 + one)
                temp2 = two*sum2
                temp = ti**2
                tk = one
                do k = 1, n
                    tj = tk
                    do j = k, n
                        fjac(k, j) = fjac(k, j) &
                                    + tj*((dfloat(k - 1)/ti - temp2)*(dfloat(j - 1) &
                                    /ti - temp2) - temp1)
                        tj = ti*tj
                    end do
                    tk = temp*tk
                end do
            end do
            fjac(1, 1) = fjac(1, 1) + six*x(1)**2 - two*x(2) + three
            fjac(1, 2) = fjac(1, 2) - two*x(1)
            fjac(2, 2) = fjac(2, 2) + one
            do k = 1, n
                do j = k, n
                    fjac(j, k) = fjac(k, j)
                end do
            end do
        case (7)
            ! chebyquad function with jacobian twice correct size.
            tk = one/dfloat(n)
            do j = 1, n
                temp1 = one
                temp2 = two*x(j) - one
                temp = two*temp2
                temp3 = zero
                temp4 = two
                do k = 1, n
                    fjac(k, j) = two*tk*temp4
                    ti = four*temp2 + temp*temp4 - temp3
                    temp3 = temp4
                    temp4 = ti
                    ti = temp*temp2 - temp1
                    temp1 = temp2
                    temp2 = ti
                end do
            end do
        case (8)
            ! brown almost-linear function without error.
            prod = one
            do j = 1, n
                prod = x(j)*prod
                do k = 1, n
                    fjac(k, j) = one
                end do
                fjac(j, j) = two
            end do
            do j = 1, n
                temp = x(j)
                if (temp == zero) then
                    temp = one
                    prod = one
                    do k = 1, n
                        if (k /= j) prod = x(k)*prod
                    end do
                end if
                fjac(n, j) = prod/temp
            end do
        case (9)
            ! discrete boundary value function with multiplicative error
            ! affecting the jacobian diagonal.
            h = one/dfloat(n + 1)
            do k = 1, n
                temp = three*(x(k) + dfloat(k)*h + one)**2
                do j = 1, n
                    fjac(k, j) = zero
                end do
                fjac(k, k) = four + temp*h**2
                if (k /= 1) fjac(k, k - 1) = -one
                if (k /= n) fjac(k, k + 1) = -one
            end do
        case (10)
            ! discrete integral equation function with sign error affecting
            ! the jacobian diagonal.
            h = one/dfloat(n + 1)
            do k = 1, n
                tk = dfloat(k)*h
                do j = 1, n
                    tj = dfloat(j)*h
                    temp = three*(x(j) + tj + one)**2
                    fjac(k, j) = h*min(tj*(one - tk), tk*(one - tj))*temp/two
                end do
                fjac(k, k) = fjac(k, k) - one
            end do
        case (11)
            ! trigonometric function with sign errors affecting the
            ! offdiagonal elements of the jacobian.
            do j = 1, n
                temp = sin(x(j))
                do k = 1, n
                    fjac(k, j) = -temp
                end do
                fjac(j, j) = dfloat(j + 1)*temp - cos(x(j))
            end do
        case (12)
            ! variably dimensioned function with operation error affecting
            ! the upper triangular elements of the jacobian.
            sum = zero
            do j = 1, n
                sum = sum + dfloat(j)*(x(j) - one)
            end do
            temp = one + six*sum**2
            do k = 1, n
                do j = k, n
                    fjac(k, j) = dfloat(k*j)/temp
                    fjac(j, k) = fjac(k, j)
                end do
                fjac(k, k) = fjac(k, k) + one
            end do
        case (13)
            ! broyden tridiagonal function without error.
            do k = 1, n
                do j = 1, n
                    fjac(k, j) = zero
                end do
                fjac(k, k) = three - four*x(k)
                if (k /= 1) fjac(k, k - 1) = -one
                if (k /= n) fjac(k, k + 1) = -two
            end do
        case (14)
            ! broyden banded function with sign error affecting the jacobian
            ! diagonal.
            ml = 5
            mu = 1
            do k = 1, n
                do j = 1, n
                    fjac(k, j) = zero
                end do
                k1 = max(1, k - ml)
                k2 = min(k + mu, n)
                do j = k1, k2
                    if (j /= k) fjac(k, j) = -(one + two*x(j))
                end do
                fjac(k, k) = two - fiftn*x(k)**2
            end do
        case default
            ! rosenbrock function with sign reversal affecting element (1,1).
            fjac(1, 1) = one
            fjac(1, 2) = zero
            fjac(2, 1) = -twenty*x(1)
            fjac(2, 2) = ten
        end select

    end subroutine errjac
!*****************************************************************************************

!*****************************************************************************************
!>
!  This subroutine specifies the standard starting points for
!  the functions defined by subroutine vecfcn. the subroutine
!  returns in x a multiple (factor) of the standard starting
!  point. for the sixth function the standard starting point is
!  zero, so in this case, if factor is not unity, then the
!  subroutine returns the vector  x(j) = factor, j=1,...,n.

    subroutine initpt(n, x, Nprob, Factor)
        implicit none

        integer,intent(in) :: n !! a positive integer input variable.
        real(wp),intent(out) :: x(n) !! an output array of length n which contains the standard
                                     !! starting point for problem nprob multiplied by factor.
        integer,intent(in) :: Nprob !! a positive integer input variable which defines the
                                    !! number of the problem. nprob must not exceed 14.
        real(wp),intent(in) :: Factor !! an input variable which specifies the multiple of
                                      !! the standard starting point. if factor is unity, no
                                      !! multiplication is performed.

        real(wp) :: zero = 0.0_wp
        real(wp) :: half = 5.0e-1_wp
        real(wp) :: one = 1.0_wp
        real(wp) :: three = 3.0_wp
        real(wp) :: c1 = 1.2_wp

        integer :: j
        real(wp) :: h, tj

        x(1:n) = zero

        ! selection of initial point.

        select case (Nprob)
        case (2)
            ! powell singular function.
            x(1) = three
            x(2) = -one
            x(3) = zero
            x(4) = one
        case (3)
            ! powell badly scaled function.
            x(1) = zero
            x(2) = one
        case (4)
            ! wood function.
            x(1) = -three
            x(2) = -one
            x(3) = -three
            x(4) = -one
        case (5)
            ! helical valley function.
            x(1) = -one
            x(2) = zero
            x(3) = zero
        case (6)
            ! watson function.
            do j = 1, n
                x(j) = zero
            end do
        case (7)
            ! chebyquad function.
            h = one/dfloat(n + 1)
            do j = 1, n
                x(j) = dfloat(j)*h
            end do
        case (8)
            ! brown almost-linear function.
            do j = 1, n
                x(j) = half
            end do
        case (9, 10)
            ! discrete boundary value and integral equation functions.
            h = one/dfloat(n + 1)
            do j = 1, n
                tj = dfloat(j)*h
                x(j) = tj*(tj - one)
            end do
        case (11)
            ! trigonometric function.
            h = one/dfloat(n)
            do j = 1, n
                x(j) = h
            end do
        case (12)
            ! variably dimensioned function.
            h = one/dfloat(n)
            do j = 1, n
                x(j) = one - dfloat(j)*h
            end do
        case (13, 14)
            ! broyden tridiagonal and banded functions.
            do j = 1, n
                x(j) = -one
            end do
        case default
            ! rosenbrock function.
            x(1) = -c1
            x(2) = one
        end select

        ! Compute multiple of initial point.

        if (factor /= one) then
            if (nprob == 6) then
                do j = 1, n
                    x(j) = factor
                end do
            else
                do j = 1, n
                    x(j) = factor*x(j)
                end do
            end if
        end if

    end subroutine initpt
!*****************************************************************************************

!*****************************************************************************************
!>
!  This subroutine defines fourteen test functions. the first
!  five test functions are of dimensions 2,4,2,4,3, respectively,
!  while the remaining test functions are of variable dimension
!  n for any n greater than or equal to 1 (problem 6 is an
!  exception to this, since it does not allow n = 1).

    subroutine vecfcn(n, x, Fvec, Nprob)
        implicit none

        integer,intent(in) :: n !! a positive integer input variable.
        integer,intent(in) :: Nprob !! a positive integer input variable which defines the
                                    !! number of the problem. nprob must not exceed 14.
        real(wp),intent(in) :: x(n) !!  an input array of length n.
        real(wp),intent(out) :: Fvec(n) !! an output array of length n which contains the nprob
                                        !! function vector evaluated at x.

        real(wp),parameter :: zero = 0.0_wp
        real(wp),parameter :: one = 1.0_wp
        real(wp),parameter :: two = 2.0_wp
        real(wp),parameter :: three = 3.0_wp
        real(wp),parameter :: five = 5.0_wp
        real(wp),parameter :: eight = 8.0_wp
        real(wp),parameter :: ten = 10.0_wp
        real(wp),parameter :: c1 = 1.0e4_wp
        real(wp),parameter :: c2 = 1.0001_wp
        real(wp),parameter :: c3 = 2.0e2_wp
        real(wp),parameter :: c4 = 2.02e1_wp
        real(wp),parameter :: c5 = 1.98e1_wp
        real(wp),parameter :: c6 = 1.8e2_wp
        real(wp),parameter :: c7 = 2.5e-1_wp
        real(wp),parameter :: c8 = 5.0e-1_wp
        real(wp),parameter :: c9 = 2.9e1_wp
        real(wp),parameter :: tpi = eight*atan(one)

        integer :: i, iev, j, k, k1, k2, kp1, ml, mu
        real(wp) :: h, prod, sum, sum1, sum2, temp, temp1, &
                    temp2, ti, tj, tk

        Fvec(1:n) = zero

        ! problem selector.

        select case (nprob)
        case (2)
            ! powell singular function.
            fvec(1) = x(1) + ten*x(2)
            fvec(2) = sqrt(five)*(x(3) - x(4))
            fvec(3) = (x(2) - two*x(3))**2
            fvec(4) = sqrt(ten)*(x(1) - x(4))**2
        case (3)
            ! powell badly scaled function.
            fvec(1) = c1*x(1)*x(2) - one
            fvec(2) = exp(-x(1)) + exp(-x(2)) - c2
        case (4)
            ! wood function.
            temp1 = x(2) - x(1)**2
            temp2 = x(4) - x(3)**2
            fvec(1) = -c3*x(1)*temp1 - (one - x(1))
            fvec(2) = c3*temp1 + c4*(x(2) - one) + c5*(x(4) - one)
            fvec(3) = -c6*x(3)*temp2 - (one - x(3))
            fvec(4) = c6*temp2 + c4*(x(4) - one) + c5*(x(2) - one)
        case (5)
            ! helical valley function.
            temp1 = sign(c7, x(2))
            if (x(1) > zero) temp1 = atan(x(2)/x(1))/tpi
            if (x(1) < zero) temp1 = atan(x(2)/x(1))/tpi + c8
            temp2 = sqrt(x(1)**2 + x(2)**2)
            fvec(1) = ten*(x(3) - ten*temp1)
            fvec(2) = ten*(temp2 - one)
            fvec(3) = x(3)
        case (6)
            ! watson function.
            do k = 1, n
                fvec(k) = zero
            end do
            do i = 1, 29
                ti = dfloat(i)/c9
                sum1 = zero
                temp = one
                do j = 2, n
                    sum1 = sum1 + dfloat(j - 1)*temp*x(j)
                    temp = ti*temp
                end do
                sum2 = zero
                temp = one
                do j = 1, n
                    sum2 = sum2 + temp*x(j)
                    temp = ti*temp
                end do
                temp1 = sum1 - sum2**2 - one
                temp2 = two*ti*sum2
                temp = one/ti
                do k = 1, n
                    fvec(k) = fvec(k) + temp*(dfloat(k - 1) - temp2)*temp1
                    temp = ti*temp
                end do
            end do
            temp = x(2) - x(1)**2 - one
            fvec(1) = fvec(1) + x(1)*(one - two*temp)
            fvec(2) = fvec(2) + temp
        case (7)
            ! chebyquad function.
            do k = 1, n
                fvec(k) = zero
            end do
            do j = 1, n
                temp1 = one
                temp2 = two*x(j) - one
                temp = two*temp2
                do i = 1, n
                    fvec(i) = fvec(i) + temp2
                    ti = temp*temp2 - temp1
                    temp1 = temp2
                    temp2 = ti
                end do
            end do
            tk = one/dfloat(n)
            iev = -1
            do k = 1, n
                fvec(k) = tk*fvec(k)
                if (iev > 0) fvec(k) = fvec(k) + one/(dfloat(k)**2 - one)
                iev = -iev
            end do
        case (8)
            ! brown almost-linear function.
            sum = -dfloat(n + 1)
            prod = one
            do j = 1, n
                sum = sum + x(j)
                prod = x(j)*prod
            end do
            do k = 1, n
                fvec(k) = x(k) + sum
            end do
            fvec(n) = prod - one
        case (9)
            ! discrete boundary value function.
            h = one/dfloat(n + 1)
            do k = 1, n
                temp = (x(k) + dfloat(k)*h + one)**3
                temp1 = zero
                if (k /= 1) temp1 = x(k - 1)
                temp2 = zero
                if (k /= n) temp2 = x(k + 1)
                fvec(k) = two*x(k) - temp1 - temp2 + temp*h**2/two
            end do
        case (10)
            ! discrete integral equation function.
            h = one/dfloat(n + 1)
            do k = 1, n
                tk = dfloat(k)*h
                sum1 = zero
                do j = 1, k
                    tj = dfloat(j)*h
                    temp = (x(j) + tj + one)**3
                    sum1 = sum1 + tj*temp
                end do
                sum2 = zero
                kp1 = k + 1
                if (n >= kp1) then
                    do j = kp1, n
                        tj = dfloat(j)*h
                        temp = (x(j) + tj + one)**3
                        sum2 = sum2 + (one - tj)*temp
                    end do
                end if
                fvec(k) = x(k) + h*((one - tk)*sum1 + tk*sum2)/two
            end do
        case (11)
            ! trigonometric function.
            sum = zero
            do j = 1, n
                fvec(j) = cos(x(j))
                sum = sum + fvec(j)
            end do
            do k = 1, n
                fvec(k) = dfloat(n + k) - sin(x(k)) - sum - dfloat(k)*fvec(k)
            end do
        case (12)
            ! variably dimensioned function.
            sum = zero
            do j = 1, n
                sum = sum + dfloat(j)*(x(j) - one)
            end do
            temp = sum*(one + two*sum**2)
            do k = 1, n
                fvec(k) = x(k) - one + dfloat(k)*temp
            end do
        case (13)
            ! broyden tridiagonal function.
            do k = 1, n
                temp = (three - two*x(k))*x(k)
                temp1 = zero
                if (k /= 1) temp1 = x(k - 1)
                temp2 = zero
                if (k /= n) temp2 = x(k + 1)
                fvec(k) = temp - temp1 - two*temp2 + one
            end do
        case (14)
            ! broyden banded function.
            ml = 5
            mu = 1
            do k = 1, n
                k1 = max(1, k - ml)
                k2 = min(k + mu, n)
                temp = zero
                do j = k1, k2
                    if (j /= k) temp = temp + x(j)*(one + x(j))
                end do
                fvec(k) = x(k)*(two + five*x(k)**2) + one - temp
            end do
        case default
            ! rosenbrock function.
            fvec(1) = one - x(1)
            fvec(2) = ten*(x(2) - x(1)**2)
        end select

    end subroutine vecfcn

end program test_chkder


C      SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV)
C
C  CONSTRUCTION AND/OR APPLICATION OF A SINGLE
C  HOUSEHOLDER TRANSFORMATION..     Q = I + U*(U**T)/B
C
C  The original version of this code was developed by
C  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
C  1973 JUN 12, and published in the book
C  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
C  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C     ------------------------------------------------------------------
C                     Subroutine Arguments
C
C     MODE   = 1 OR 2   Selects Algorithm H1 to construct and apply a
C            Householder transformation, or Algorithm H2 to apply a
C            previously constructed transformation.
C     LPIVOT IS THE INDEX OF THE PIVOT ELEMENT.
C     L1,M   IF L1 .LE. M   THE TRANSFORMATION WILL BE CONSTRUCTED TO
C            ZERO ELEMENTS INDEXED FROM L1 THROUGH M.   IF L1 GT. M
C            THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
C     U(),IUE,UP    On entry with MODE = 1, U() contains the pivot
C            vector.  IUE is the storage increment between elements.
C            On exit when MODE = 1, U() and UP contain quantities
C            defining the vector U of the Householder transformation.
C            on entry with MODE = 2, U() and UP should contain
C            quantities previously computed with MODE = 1.  These will
C            not be modified during the entry with MODE = 2.
C     C()    ON ENTRY with MODE = 1 or 2, C() CONTAINS A MATRIX WHICH
C            WILL BE REGARDED AS A SET OF VECTORS TO WHICH THE
C            HOUSEHOLDER TRANSFORMATION IS TO BE APPLIED.
C            ON EXIT C() CONTAINS THE SET OF TRANSFORMED VECTORS.
C     ICE    STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C().
C     ICV    STORAGE INCREMENT BETWEEN VECTORS IN C().
C     NCV    NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0
C            NO OPERATIONS WILL BE DONE ON C().
C     ------------------------------------------------------------------
      SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV)
C     ------------------------------------------------------------------
      integer I, I2, I3, I4, ICE, ICV, INCR, IUE, J
      integer L1, LPIVOT, M, MODE, NCV
      double precision B, C(*), CL, CLINV, ONE, SM
C     double precision U(IUE,M)
      double precision U(IUE,*)
      double precision UP
      parameter(ONE = 1.0d0)
C     ------------------------------------------------------------------
      IF (0.GE.LPIVOT.OR.LPIVOT.GE.L1.OR.L1.GT.M) RETURN
      CL=abs(U(1,LPIVOT))
      IF (MODE.EQ.2) GO TO 60
C                            ****** CONSTRUCT THE TRANSFORMATION. ******
          DO 10 J=L1,M
   10     CL=MAX(abs(U(1,J)),CL)
      IF (CL) 130,130,20
   20 CLINV=ONE/CL
      SM=(U(1,LPIVOT)*CLINV)**2
          DO 30 J=L1,M
   30     SM=SM+(U(1,J)*CLINV)**2
      CL=CL*SQRT(SM)
      IF (U(1,LPIVOT)) 50,50,40
   40 CL=-CL
   50 UP=U(1,LPIVOT)-CL
      U(1,LPIVOT)=CL
      GO TO 70
C            ****** APPLY THE TRANSFORMATION  I+U*(U**T)/B  TO C. ******
C
   60 IF (CL) 130,130,70
   70 IF (NCV.LE.0) RETURN
      B= UP*U(1,LPIVOT)
C                       B  MUST BE NONPOSITIVE HERE.  IF B = 0., RETURN.
C
      IF (B) 80,130,130
   80 B=ONE/B
      I2=1-ICV+ICE*(LPIVOT-1)
      INCR=ICE*(L1-LPIVOT)
          DO 120 J=1,NCV
          I2=I2+ICV
          I3=I2+INCR
          I4=I3
          SM=C(I2)*UP
              DO 90 I=L1,M
              SM=SM+C(I3)*U(1,I)
   90         I3=I3+ICE
          IF (SM) 100,120,100
  100     SM=SM*B
          C(I2)=C(I2)+SM*UP
              DO 110 I=L1,M
              C(I4)=C(I4)+SM*U(1,I)
  110         I4=I4+ICE
  120     CONTINUE
  130 RETURN
      END


!
! ej3a.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! 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; either version 2 of the License, or
! (at your option) any later version.
!
! 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.
!
program integralMC
use precision, pr => dp
use mtmod

implicit none
integer                     :: i, j, k
real(pr)                    :: x, Imc, exact, error, cum

open(unit=10, file='ej3a.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#   n   Imc  err   "

exact=0.25
cum = 0
do i = 1, 100000
    x = grnd()
    cum = cum + f(x)
    if (mod(i, 10)==0) then
        Imc = cum/real(i, pr)
        error = abs(exact - Imc)
        write(10, *) i, Imc, error
    end if
end do

contains

function f(x)
implicit none
real(pr)                    :: f, x

f = x**3.
end function f

end program


module types
  ! ----------------------------------------------------------------
  ! cosmetics:
  !   This module contains all types and formats
  ! author:
  !   Exam-roll -- 20419PHY083
  ! env details:
  !   compiler -- gfortran v10.2.0
  !   OS       -- macOS 12.0 x86_64
  !   Kernel   -- Darwin 21.0.0
  ! Note:
  !   - used for the module "tools"
  ! ----------------------------------------------------------------
  implicit none

  ! various parameters used across my programs
  integer, parameter :: dp = selected_real_kind(15, 307) ! double precession
  real(dp), parameter :: pi = 4.d0*atan(1.d0) ! value of PI

  ! format specifier section
  ! the "----" lines
  character(len=15), parameter :: line2 = "(1x,2a10)"
  character(len=20), parameter :: line3 = "(a8,2(2x,a8))"
  character(len=25), parameter :: line3n = "(2(2x,a8),10x,a25)"
  character(len=25), parameter :: line5 = "(a8,3(2x,a8),5x,a8)"
  character(len=25), parameter :: line6 = "(a8,4(2x,a8),5x,a8)"
  ! the table headers
  character(len=15), parameter :: form_header2 = "(3x,a8,2x,a8)"
  character(len=20), parameter :: form_header3 = "(/,a5,2(5x,a5))"
  character(len=25), parameter :: form_header3n = "(/,3x,a5,4x,a5,20x,a8)"
  character(len=25), parameter :: form_header5 = "(/,a6,3(5x,a5),8x,a6)"
  character(len=25), parameter :: form_header6 = "(/,a6,4(5x,a5),8x,a6)"
  ! the table datas
  character(len=10), parameter :: form_table2 = "(2f10.4)"
  character(len=20), parameter :: form_table3 = "(i5,3x,2f10.4)"
  character(len=30), parameter :: form_table5 = "(i5,3x,3F10.4,2(3x,f10.5))"
  character(len=30), parameter :: form_table6 = "(i5,3x,4F10.4,3x,f10.5)"
  character(len=30), parameter :: form_tableip = "(f10.2, 10f10.4)"
  ! the final results
  character(len=15), parameter :: form_result1rj = "(f10.4,2x,a,i1)"
  character(len=15), parameter :: form_result2r = "(f10.4,2x,a)"
  character(len=15), parameter :: form_result2rp = "(f15.8,2x,a)"
  character(len=15), parameter :: form_result2i = "(i15,2x,a)"
  character(len=15), parameter :: form_result2c = "(3x,a10,a28)"

end module types


      program PI
      implicit none
      integer i, num_iter
      double precision x, my_pi, contrib, iter
      contrib = 0.0
      num_iter = 10
      iter = 1.0/num_iter

!$OMP PARALLEL DO REDUCTION (+:contrib)
      DO i = 1, num_iter
	 x = (i-0.5)*iter
	 contrib = contrib + 4.0/(1.0+x*x)
	 print *, i,x,contrib
      END DO
!$OMP END PARALLEL DO

      my_pi = iter * contrib

      print *,my_pi
      END