      SUBROUTINE SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE,
     $                   LDSE, PRE, LDPRE, TOL, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compare two multivariable sequences M1(k) and M2(k) for
C     k = 1,2,...,N, and evaluate their closeness. Each of the
C     parameters M1(k) and M2(k) is an NC by NB matrix.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of parameters.  N >= 0.
C
C     NC      (input) INTEGER
C             The number of rows in M1(k) and M2(k).  NC >= 0.
C
C     NB      (input) INTEGER
C             The number of columns in M1(k) and M2(k).  NB >= 0.
C
C     H1      (input) DOUBLE PRECISION array, dimension (LDH1,N*NB)
C             The leading NC-by-N*NB part of this array must contain
C             the multivariable sequence M1(k), where k = 1,2,...,N.
C             Each parameter M1(k) is an NC-by-NB matrix, whose
C             (i,j)-th element must be stored in H1(i,(k-1)*NB+j) for
C             i = 1,2,...,NC and j = 1,2,...,NB.
C
C     LDH1    INTEGER
C             The leading dimension of array H1.  LDH1 >= MAX(1,NC).
C
C     H2      (input) DOUBLE PRECISION array, dimension (LDH2,N*NB)
C             The leading NC-by-N*NB part of this array must contain
C             the multivariable sequence M2(k), where k = 1,2,...,N.
C             Each parameter M2(k) is an NC-by-NB matrix, whose
C             (i,j)-th element must be stored in H2(i,(k-1)*NB+j) for
C             i = 1,2,...,NC and j = 1,2,...,NB.
C
C     LDH2    INTEGER
C             The leading dimension of array H2.  LDH2 >= MAX(1,NC).
C
C     SS      (output) DOUBLE PRECISION array, dimension (LDSS,NB)
C             The leading NC-by-NB part of this array contains the
C             matrix SS.
C
C     LDSS    INTEGER
C             The leading dimension of array SS.  LDSS >= MAX(1,NC).
C
C     SE      (output) DOUBLE PRECISION array, dimension (LDSE,NB)
C             The leading NC-by-NB part of this array contains the
C             quadratic error matrix SE.
C
C     LDSE    INTEGER
C             The leading dimension of array SE.  LDSE >= MAX(1,NC).
C
C     PRE     (output) DOUBLE PRECISION array, dimension (LDPRE,NB)
C             The leading NC-by-NB part of this array contains the
C             percentage relative error matrix PRE.
C
C     LDPRE   INTEGER
C             The leading dimension of array PRE.  LDPRE >= MAX(1,NC).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in the computation of the error
C             matrices SE and PRE. If the user sets TOL to be less than
C             EPS then the tolerance is taken as EPS, where EPS is the
C             machine precision (see LAPACK Library routine DLAMCH).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The (i,j)-th element of the matrix SS is defined by:
C                        N          2
C               SS    = SUM  M1  (k) .                            (1)
C                 ij    k=1    ij
C
C     The (i,j)-th element of the quadratic error matrix SE is defined
C     by:
C                        N                      2
C               SE    = SUM  (M1  (k) - M2  (k)) .                (2)
C                 ij    k=1     ij        ij
C
C     The (i,j)-th element of the percentage relative error matrix PRE
C     is defined by:
C
C               PRE   = 100 x SQRT( SE  / SS  ).                  (3)
C                  ij                 ij    ij
C
C     The following precautions are taken by the routine to guard
C     against underflow and overflow:
C
C     (i) if ABS( M1  (k) ) > 1/TOL or ABS( M1  (k) - M2  (k) ) > 1/TOL,
C                   ij                        ij        ij
C
C         then SE   and SS   are set to 1/TOL and PRE   is set to 1; and
C                ij       ij                         ij
C
C     (ii) if ABS( SS  ) <= TOL, then PRE   is set to 100.
C                    ij                  ij
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately
C        2xNBxNCx(N+1) multiplications/divisions,
C        4xNBxNCxN     additions/subtractions and
C          NBxNC       square roots.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB09AD by S. Van Huffel, Katholieke
C     University Leuven, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Closeness multivariable sequences, elementary matrix operations,
C     real signals, system response.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, HUNDRD
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, HUNDRD = 100.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH1, LDH2, LDPRE, LDSE, LDSS, N, NB, NC
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  H1(LDH1,*), H2(LDH2,*), PRE(LDPRE,*),
     $                  SE(LDSE,*), SS(LDSS,*)
C     .. Local Scalars ..
      LOGICAL           NOFLOW
      INTEGER           I, J, K
      DOUBLE PRECISION  EPSO, SSE, SSS, TOLER, VAR, VARE
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, SQRT
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NC.LT.0 ) THEN
         INFO = -2
      ELSE IF( NB.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDH1.LT.MAX( 1, NC ) ) THEN
         INFO = -5
      ELSE IF( LDH2.LT.MAX( 1, NC ) ) THEN
         INFO = -7
      ELSE IF( LDSS.LT.MAX( 1, NC ) ) THEN
         INFO = -9
      ELSE IF( LDSE.LT.MAX( 1, NC ) ) THEN
         INFO = -11
      ELSE IF( LDPRE.LT.MAX( 1, NC ) ) THEN
         INFO = -13
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB09MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. NC.EQ.0 .OR. NB.EQ.0 )
     $   RETURN
C
      TOLER = MAX( TOL, DLAMCH( 'Epsilon' ) )
      EPSO = ONE/TOLER
C
      DO 60 J = 1, NB
C
         DO 40 I = 1, NC
            SSE = ZERO
            SSS = ZERO
            NOFLOW = .TRUE.
            K  = 0
C
C           WHILE ( ( NOFLOW .AND. ( K .LT. N*NB ) ) DO
   20       IF ( ( NOFLOW ) .AND. ( K.LT.N*NB ) ) THEN
               VAR  = H1(I,K+J)
               VARE = H2(I,K+J) - VAR
               IF ( ABS( VAR ).GT.EPSO .OR. ABS( VARE ).GT.EPSO )
     $            THEN
                  SE(I,J) = EPSO
                  SS(I,J) = EPSO
                  PRE(I,J) = ONE
                  NOFLOW = .FALSE.
               ELSE
                  IF ( ABS( VARE ).GT.TOLER ) SSE = SSE + VARE*VARE
                  IF ( ABS( VAR  ).GT.TOLER ) SSS = SSS + VAR*VAR
                  K  = K + NB
               END IF
               GO TO 20
            END IF
C           END WHILE 20
C
            IF ( NOFLOW ) THEN
               SE(I,J) = SSE
               SS(I,J) = SSS
               PRE(I,J) = HUNDRD
               IF ( SSS.GT.TOLER ) PRE(I,J) = SQRT( SSE/SSS )*HUNDRD
            END IF
   40    CONTINUE
C
   60 CONTINUE
C
      RETURN
C *** Last line of SB09MD ***
      END


*
* payroll - calculate pay given time and a half for overtime
*
*  Written by: C. Severance 16Mar92
*
* Declare the variables:
*
      REAL RATE,HOURS,PAY
*
* Prompt the user for hours and the rate
*
      PRINT *,'Enter the hours worked - '
      READ *,HOURS
      PRINT *,'Enter the pay per hour -'
      READ *,RATE
*
* Calculate the pay compensating for overtime
*
      IF ( HOURS .GT. 40.0 ) THEN
        PAY = RATE * 40.0 + ( RATE * 1.5 * (HOURS - 40.0))
      ELSE
        PAY = RATE * HOURS
      ENDIF
*
* Print out the pay
*
      PRINT *,'PAY is - ',PAY
      END


C
	SUBROUTINE ROTATE_Z(ANGLE,X_INIT,X_TRANS)
C
	REAL X_INIT(3),X_TRANS(3)
C
	X_TRANS(1)=X_INIT(1)*COS(ANGLE)+X_INIT(2)*SIN(ANGLE)
	X_TRANS(2)=X_INIT(2)*COS(ANGLE)-X_INIT(1)*SIN(ANGLE)
	X_TRANS(3)=X_INIT(3)
C
	RETURN
	END


	FUNCTION PR_MSKN  ( sped )
C************************************************************************
C* PR_MSKN								*
C*									*
C* This function computes SKNT from SPED.  The following equation is	*
C* used:					 			*
C*									*
C*                 SKNT  =  SPED * 1.9425 				*
C*									*
C* REAL PR_MSKN  ( SPED )						*
C*									*
C* Input parameters:							*
C*	SPED		REAL		Speed in meters/second		*
C*									*
C* Output parameters:							*
C*	PR_MSKN		REAL		Speed in knots			*
C**									*
C* Log:									*
C* I. Graffman/CSC	8/83	Original source code			*
C* M. Goodman/RDS  	3/84	Modified prologue 			*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	7/88	Documentation				*
C* L. Sager/NCEP	4/96	Updated knots to m/sec conversion	*
C*				factor to NCEP standard			*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( sped ) )  THEN
	    PR_MSKN = RMISSD
	  ELSE
	    PR_MSKN = 1.9425 * sped
	END IF
C*
	RETURN
	END


Subroutine lorenz(energy, px, py, pz, bex, bey, bez)
  Implicit Double Precision (A-H, O-Z)
  Common /lor/enenew, pxnew, pynew, pznew
  Save
  beta2 = bex**2 + bey**2 + bez**2
  If (beta2==0D0) Then
     enenew = energy
     pxnew = px
     pynew = py
     pznew = pz
  Else
     If (beta2>0.999999999999999D0) Then
        beta2 = 0.999999999999999D0
        Print *, 'beta2=0.999999999999999'
     End If
     gam = 1.D0/dsqrt(1.D0-beta2)
     enenew = gam*(energy-bex*px-bey*py-bez*pz)
     pxnew = -gam*bex*energy + (1.D0+(gam-1.D0)*bex**2/beta2)*px + (gam-1.D0)*bex*bey/beta2*py + (gam-1.D0)*bex*bez/beta2*pz
     pynew = -gam*bey*energy + (gam-1.D0)*bex*bey/beta2*px + (1.D0+(gam-1.D0)*bey**2/beta2)*py + (gam-1.D0)*bey*bez/beta2*pz
     pznew = -gam*bez*energy + (gam-1.D0)*bex*bez/beta2*px + (gam-1.D0)*bey*bez/beta2*py + (1.D0+(gam-1.D0)*bez**2/beta2)*pz
  End If
  Return
End Subroutine lorenz


program problem75
  implicit none
  integer, parameter        :: limit=1500000
  integer, dimension(limit) :: counts
  integer                   :: m,n,k,a,b,c,L,answer

  do k=1,limit
     counts(k)=0
  end do
  answer=0

  ! https://en.wikipedia.org/wiki/Pythagorean_triple#Generating_a_triple
  do m=1,int(ceiling(sqrt(dble(limit))))
     do n=1,m-1
        if (.not. predicate(m,n)) cycle
        a=(m*m)-(n*n)
        b=2*m*n
        c=(m*m)+(n*n)
        if (a<1) cycle
        L=a+b+c
        k=1
        do while(k*L<=limit)
           counts(k*L)=counts(k*L)+1
           k=k+1
        end do
     end do
  end do

  do k=1,limit
     if (counts(k)==1) answer=answer+1
  end do

  print *,answer

contains

  pure function predicate(a,b)
    use euler
    implicit none
    integer, intent(in) :: a,b
    logical             :: predicate

    predicate=(gcd(int(a,8),int(b,8))==1 .and. (mod(a,2)==0 .or. mod(b,2)==0))

  end function predicate

end program problem75


      FUNCTION beta(z,w)
      REAL beta,w,z
CU    USES gammln
      REAL gammln
      beta=exp(gammln(z)+gammln(w)-gammln(z+w))
      return
      END

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


!! `fpm test` or `fpm test test`
program main
    block
        use forlab, only: empty, disp, operator(.x.)
        real, dimension(:, :), allocatable :: x_sp, y_sp
        real(8), dimension(:, :), allocatable :: x_dp, y_dp
        real(16), dimension(:, :), allocatable :: x_qp, y_qp

        x_sp = empty(2, 2); x_dp = empty(2, 2); x_qp = empty(2, 2)
        y_sp = empty(2, 2); y_dp = empty(2, 2); y_qp = empty(2, 2)

        x_sp = 1.; x_dp = 1.; x_qp = 1.
        y_sp = 2.; y_dp = 2.; y_qp = 2.

        call disp('----------------------------')
        call disp(x_sp.x.y_sp, 'x .x. y SP✨:')
        call disp(x_dp.x.y_dp, 'x .x. y DP✨:')
        call disp(x_qp.x.y_qp, 'x .x. y QP✨:')
    end block

    block
        use forlab, only: operator(.i.), disp
        ! test inv and solve equation Ax=b, A^(-1) * b
        real :: a(2, 2) = reshape([1, 2, 3, 1], [2, 2])
        real :: b(2) = [1, 1]
        call disp("Test Inv and solve equation Ax=b")
        call disp('A=')
        call disp(a)
        call disp("b=")
        call disp(b)
        call disp("x=")
        call disp(matmul(.i.a, b))
    end block

    block
        use forlab, only: acosd, tand, disp
        ! test degrees circular function
        call disp('Test degrees circular function')
        call disp("acosd(1.d0)=")
        call disp(acosd(1.d0))
        call disp("tand([45.0,60.0,0.0])")
        call disp(tand([45.0, 60.0, 0.0]))
    end block
end program


module ArrayOps

  use utils, only : dp

  implicit none

contains

  function linspace(start, end, N) result(samples)
    real(dp), intent(in)  :: start, end
    integer, intent(in)   :: N
    real(dp)              :: samples(N), step
    integer               :: i

    step = (end - start) / real(N - 1, dp)
    do i = 1,N
       samples(i) = (i-1) * step + start
    end do
  end function linspace

  function logspace(start, end, N) result(samples)
    real(dp), intent(in) :: start, end
    integer , intent(in) :: N
    real(dp)             :: samples(N)

    samples = exp(linspace(log(start), log(end), N))

  end function logspace

  function bunchspace(center, width, N) result(samples)
    ! Like logspace, but the bunch is centered around center, not 0.
    ! It is symmetric and extends from [center - width, center + width], and
    ! puts this in arr. Total number of points will be 2N-1.
    ! center must be greater than width.
    real(dp), intent(in)    :: center, width
    integer,  intent(in)    :: N
    real(dp)                :: logsamples(N), samples(2*N-1), begin

    begin = center - width

    ! Treat first part of samples as a temporary holder at first
    logsamples = exp(linspace(log(begin), log(center), N))
    samples(N:1:-1) = (center + begin) - logsamples
    samples(N+1:)= width + logsamples(2:)

  end function bunchspace

  function binarysearch(arr, val) result(index)
    ! Search through a real array arr to look for the value val using the binary
    ! search algorithm. If val does not exist in arr, return the index of the
    ! element in arr that occurs immediately AFTER val.

    real(dp), intent(in) :: arr(:), val
    integer              :: index, L, R, mid

    L = 1
    R = size(arr)
    do while ((L <= R))
       mid = floor((L+R)/ real(2,dp))
       if (arr(mid) < val) then
          L = mid + 1
       else if (arr(mid) > val) then
          R = mid - 1
       else
          index = mid
          return
       end if
    end do
    index = L
    return
  end function binarysearch

  ! subroutine sortpositive(a, inp)
  !   ! Sort numbers in array a (in place) and note the index that separates the
  !   ! negative points from the positive points
  !   real(dp), intent(inout) :: a(:)
  !   integer, intent(out) :: inp
  !   integer :: len, i

  !   len = size(a)
  !   call quicksort(a)

  !   do i = 1,len
  !      if (a(i) >= 0.) then
  !         inp = i
  !         exit
  !      end if
  !   end do

  ! end subroutine sortpositive

  ! function sortedinsert(arr, val) result(newarr)
  !   ! Insert a value (val) into the sorted array (arr).
  !   ! Array is assumed to sorted from least to greatest.
  !   real(dp), intent(in) :: arr(:), val
  !   real(dp)             :: newarr(size(arr) + 1)
  !   integer              :: N, i

  ! end function sortedinsert

end module ArrayOps

! program main
!   use ArrayOps

!   implicit none

!   real(dp) :: A(11)
!   integer  :: i

!   A = logspace(0.01_dp, 10._dp, size(A))
!   print '(f7.4)', A
!   !i = binarysearch(A, -1._dp)
!   !print *, i

! end program main


module gauss_quad

  ! <doc>
  !  Utilities for Gaussian quadrature.
  !  This module provides subroutines to obtain zeros and weights of
  !  Gauss-Legendre and Gauss-Laguerre quadrature rules.
  ! </doc>

  implicit none

  public :: get_legendre_grids_from_cheb
  public :: get_laguerre_grids

  private

  logical :: debug=.false.
  logical :: weight_roundoff_correction=.false.

  integer, parameter :: qp = selected_real_kind(33, 4931)

contains

  subroutine get_legendre_grids_from_cheb (x1, x2, zero, wgt)

    ! <doc>
    !  returns Legendre zeros and weights in the given interval [x1,x2].
    !  The order is determined from the size of the array 'zero'.
    ! </doc>

    use constants, only: pi => dpi
    real, intent (in) :: x1, x2
    real, dimension (:), intent (out) :: zero, wgt
    integer :: i, nn, nh
    double precision :: xold, xnew, pold, pnew
    double precision, dimension (:), allocatable :: zz, ww

    nn = size(zero)
    nh = (nn+1)/2
    allocate (zz(nh))
    allocate (ww(nh))

    ! search zero from 1 to 0 using chebyshev grid points
    ! this is O(nn^2) operations
    xold = cos(pi / (2*(nn+1)))
    pold = legendre_p(nn,xold)
    do i=1, nh
       xnew = cos(pi*(2*i+1)/(2*(nn+1)))
       pnew = legendre_p(nn,xnew)
       call find_zero_bisect_newton (nn, xold, xnew, pold, pnew, zz(i))
       xold = xnew
       pold = pnew
    end do
    ! invert them to give zeros in (-1,0]
    zz(1:nn/2) = -zz(1:nn/2)

    ! weight from formula
!    ww = dble(2.0) / (dble(1.0) - zz**2) / legendre_pp(nn,zz,dble(0.0))**2
    ww = dble(2.0) / (dble(1.0) - zz**2) / legendre_pp(nn,zz)**2

    ! rescale (x2 may be smaller than x1)
    zero(1:nh) = real(zz * (x2-x1) + (x1+x2)) / 2.0
    zero(nh+1:nn) = real(zz(nn/2:1:-1) * (x1-x2) + (x1+x2)) / 2.0
    wgt(1:nh) = real(ww * abs(x2-x1) / 2.0)
    wgt(nh+1:nn) = wgt(nn/2:1:-1)

    deallocate (zz)
    deallocate (ww)

    ! roundoff correction
!!$    if (abs(sum(wgt)/abs(x2-x1)) - 1.0 > epsilon(wgt)) then
!!$       print *, 'roundoff correction occurred'
    if (weight_roundoff_correction) then
       if (mod(nn,2)==0) then
          wgt(nh) = abs(x2-x1) / 2.0 - sum(wgt(1:nh-1))
          wgt(nh+1) = wgt(nh)
       else
          wgt(nh) = abs(x2-x1) - sum(wgt(1:nh-1)) * 2.0
       end if
    end if

    call check_legendre_zero (x1, x2, zero)
    call check_legendre_weights (abs(x2-x1), wgt)

    if (debug) then
       print *, 'get_legendre_grids_from_cheb: sum of weights = ', sum(wgt)
       print *, 'get_legendre_grids_from_cheb: section length = ', abs(x2-x1)
    end if

  end subroutine get_legendre_grids_from_cheb

  subroutine find_zero_bisect_newton (n, xold, xnew, pold, pnew, zz)

    use file_utils, only: error_unit
    integer, intent (in) :: n
    double precision, intent (in) :: xold, xnew, pold, pnew
!    real, intent (in) :: eps
    double precision, intent (out) :: zz
    integer :: i, maxit=100
    real :: eps
    double precision :: x1, x2, p1, p2, pz

    ! <doc>
    !  eps is declared as real on purpose.
    !  We don't require higher order precision for convergence test
    !  because of a performance reason. The following definition means
    !  eps is a geometric mean of the machine-epsilons in real and double
    !  precisions.
    !  (note that real/double are promoted to double/double or double/quad
    !  depending on the compiler.)
    !
    !  [same applies to eps in find_zero below.]
    ! </doc>

    eps = sqrt(epsilon(eps)*epsilon(x1)) * 2.0
    i=0
    x1 = xold
    x2 = xnew
    p1 = pold
    p2 = pnew

    if (debug) write(*,'(4f10.5)') x1, p1, x2, p2

    ! bisection
    do i=1, 5
       zz = (x1+x2) * dble(.5)
       pz = legendre_p(n,zz)
       if (abs(pz) <= epsilon(pz)) return
       if (pz*p1 < 0.0) then
          p2=pz ; x2=zz
       else
          p1=pz ; x1=zz
       end if
       if (debug) write(*,'(4f10.5)') x1, p1, x2, p2
    end do

    if (debug) print*, 'finished bisection'

    ! newton-raphson
    if (zz==x1) x1 = x2
!    do while (abs(zz/x1-1.0) > eps)
    do i=1, maxit
       x1 = zz
       p1 = legendre_p(n,x1)
!       zz = x1 - p1 / legendre_pp(n,x1,p1)
       zz = x1 - p1 / legendre_pp(n,x1)
       pz = legendre_p(n,zz)
       if (debug) write (*,'(4f10.5)') zz, pz, x1, p1
       if (min(abs(zz/x1-1.0), abs(pz)) < eps) exit
    end do

    if (i==maxit+1) write (error_unit(),*) &
         & 'WARNING: too many iterations in get_legendre_grids'

    if (debug) stop

  end subroutine find_zero_bisect_newton

  elemental function legendre_p (n, x)

    integer, intent (in) :: n
    double precision, intent (in) :: x
    integer :: k
    double precision :: p, p1, p2, legendre_p

    select case (n)
    case (0)
       legendre_p = dble(1.0)
    case (1)
       legendre_p = x
    case default
       p1 = x
       p2 = dble(1.0)
       do k=2, n
          p = ((2*k-1)*x*p1 - (k-1)*p2) / k
          p2 = p1
          p1 = p
       end do
       legendre_p = p
    end select

  end function legendre_p

!  elemental function legendre_pp (n, x, p1)
  elemental function legendre_pp (n, x)

    integer, intent (in) :: n
    double precision, intent (in) :: x
!    double precision, intent (in), optional :: p1
    double precision :: legendre_pp

!    if (present(p1)) then
!       legendre_pp = n * ( x * p1 - legendre_p(n-1,x) ) &
!            / (x**2 - dble(1.0))
!    else
    legendre_pp = n * ( x * legendre_p(n,x) - legendre_p(n-1,x) ) &
         / (x**2 - dble(1.0))
!    end if

  end function legendre_pp

  subroutine check_legendre_zero (x0, x1, zero)

    use mp, only: mp_abort
    use file_utils, only: error_unit
    real, intent (in) :: x0, x1
    real, dimension (:), intent (in) :: zero
    logical :: error=.false.
    integer :: nn, nh
    real :: xx, xmin, xmax
    real, dimension (:), allocatable :: zz

    nn = size(zero)
    nh = (nn+1)/2
    error = .false.
    xmin = min(x0, x1)
    xmax = max(x0, x1)
    allocate (zz(nn))
    zz = zero
    if (zz(1) > zz(nn)) zz(1:nn) = zero(nn:1:-1)
    if (zz(1) < xmin .or. zz(nn) > xmax) then
       write (error_unit(),*) 'ERROR in legendre: grid out of range'
       error = .true.
    end if

    if (nn==1) then
       if (abs(2.0*zz(1)/(xmin+xmax) - 1.0) > epsilon(0.0)) then
          write (error_unit(), '("ERROR in legendre: zz(1)= ", f20.15)') zz(1)
          error = .true.
       end if
    else
       ! check if distances at the edge: This suffices for nn<=3
       if (zz(2)-zz(1) <= zz(1)-xmin .or. zz(nn)-zz(nn-1) <= xmax-zz(nn)) then
          write (error_unit(),*) 'ERROR in legendre: wrong distance at edge'
          error = .true.
       end if
       ! check distances at the center: The above and this suffices for nn=4
       if (mod(nn,2)==0 .and. nn>=4) then
          if ( zz(nh+1)-zz(nh) <= zz(nh)-zz(nh-1) .or. &
               zz(nh+1)-zz(nh) <= zz(nh+2)-zz(nh+1) ) then
             write (error_unit(),*) &
                  & 'ERROR in legendre: wrong distance at center'
             error = .true.
          end if
       end if
       if (nn >= 5) then
          ! check if distances are increasing toward center
          ! lower half
          if (any(zz(3:nh)-zz(2:nh-1) <= zz(2:nh-1)-zz(1:nh-2))) then
             write (error_unit(),*) 'ERROR in legendre: distance decreasing toward center'
             error = .true.
          end if
          ! upper half
          ! The separate use of nh and nn/2 are intentionally so that they
          ! both work for even and odd cases
          if ( any(zz(nn/2+2:nn-1)-zz(nn/2+1:nn-2) &
               & <= zz(nn/2+3:nn)-zz(nn/2+2:nn-1)) ) then
             write (error_unit(),*) 'ERROR in legendre: distance decreasing toward center'
             error = .true.
          end if
       end if

    end if

    ! check if legendre_p(n, zero(i)) are close enough to zero
    if (debug) then
       xx = maxval(abs(real( legendre_p(nn, &
            dble((zz(:)-xmin)/(xmax-xmin)*2.0-1.0)) )))
       if (xx/nn**2 > epsilon(xx)) then
          write (error_unit(),*) 'WARNING in legendre: maxval(n,zz(:))= ', xx
          ! Do not stop as it is mostly a minor issue
       end if
    end if

    if (error) call mp_abort ('STOP in check_legendre_zero')

  end subroutine check_legendre_zero

!  subroutine check_legendre_weights (norm, wgt, eps)
  subroutine check_legendre_weights (norm, wgt)

    use mp, only: mp_abort
    use file_utils, only: error_unit
    real, intent (in) :: norm!, eps
    real, dimension (:), intent (in) :: wgt
    logical :: error=.false.
    integer :: n, nh
    real :: s

    n = size(wgt)
    error = .false.
    nh = (n+1)/2

    ! check if weights are all positive
    if (any(wgt < 0.)) then
       write (error_unit(),*) 'ERROR in legendre: weights got negative'
       error = .true.
    end if

    if (n>=2) then
       ! check symmetry of weights
       if ( any( abs(wgt(n:n+1-n/2:-1)/wgt(1:n/2) - 1.0) > epsilon(wgt) ) ) then
          write (error_unit(),*) 'WARNING in legendre: symmetry of weights broken'
          error = .true.
       end if

       ! check if weights are increasing toward center
       if (n>=3) then
          if (any(wgt(2:nh) <= wgt(1:nh-1))) then
             write (error_unit(),*) 'ERROR in legendre: weights decreasing toward center'
             error = .true.
          end if
       end if
    end if

    ! check if their sum is close enough to normalized value
    if (debug) then
!       s = sum(wgt)
       s = sum(dble(wgt)) ! ignore roundoff error arising from 8-byte summation
       if (abs(norm/s-1.0) > epsilon(s)) then
          write (error_unit(),*) 'WARNING in legendre: weights summation incorrect:', &
               & size(wgt), s/norm-1.0
          ! Do not stop as it is mostly a minor issue
       end if
    end if

    if (error) call mp_abort ('STOP in check_legendre_weights')

  end subroutine check_legendre_weights

  subroutine get_laguerre_grids (zero, wgt)

    ! <doc>
    !  returns Laguerre zeros and weights.
    !  The order is determined from the size of the array 'zero'.
    ! </doc>

    use mp, only: mp_abort
    use file_utils, only: error_unit
    real, dimension (:), intent (out) :: zero
    real, dimension (:), intent (out) :: wgt
    logical :: error=.false.
    integer :: i, j, n, nzero
    real(kind=qp) :: x, delx, pold, pnew
    !double precision, dimension (:), allocatable :: zz
    real(kind=qp), dimension (:), allocatable :: zz
    double precision :: eps

    n = size (zero)
    allocate (zz(n))
    zz = 0.0

    eps = epsilon(zero(1))*dble(4.0)

    if (n > 180) then
       write (error_unit(),*) 'ERROR: can''t get so many laguerre grid points'
       write (error_unit(),*) 'ERROR: size(zero)= ', n
       error = .true.
    end if

    ! search zero from 0 to xmax using evenly spaced grid points
    if (n==1) then

       zero(1) = 1.0
       wgt(1) = 1.0
       return

    else

       nzero = 0
       pold = real(laguerre_l(n,real(0.0,qp)),qp)
       delx = 0.001
       do i=1, 1000      ! up to x=1
          x = delx*i
!          print*, x
          pnew = real(laguerre_l(n,x),qp)
!          if (pold*pnew < epsilon(0.0)) then
          if (pold*pnew < 0.0) then
             nzero = nzero+1
             call find_zero (n, eps, x-delx, x, pold, pnew, zz(nzero))
          end if
          pold=pnew
       end do

       do j=0, 3
          delx = delx * 10.
          do i=1, 900
             x = delx*(i+100)
!             print*, x
             pnew = laguerre_l(n,x)
             if (pold*pnew < 0.0) then
                nzero = nzero+1
                call find_zero (n, eps, x-delx, x, pold, pnew, zz(nzero))
             end if
             if (nzero == n) exit
             pold=pnew
          end do
          if (nzero == n) exit
       end do

    end if

    zero = real(zz,kind(zero(1)))
    wgt = real(zz / (n+1)**2 / laguerre_l(n+1,zz)**2,kind(wgt(1)))

    deallocate (zz)

    ! roundoff correction
    if (weight_roundoff_correction) then
       i = sum(maxloc(wgt))
       wgt(i) = 1.0 - sum(wgt(1:i-1)) - sum(wgt(i+1:n))
    end if

    ! check number of found zeros
    if (nzero < n) then
       write (error_unit(),*) 'ERROR in laguerre: didn''t find all zeros'
       do i=1, n
          write (error_unit(),*) i, zero(i)
       end do
       stop
    end if

    call check_laguerre_zeros (zero)
    call check_laguerre_weights (wgt,eps=1.0e-7)

    if (error) call mp_abort ('STOP in get_laguerre_grids')

  end subroutine get_laguerre_grids

  subroutine find_zero (n, eps, xold, xnew, pold, pnew, zz)

    use file_utils, only: error_unit
    integer, intent (in) :: n
    double precision, intent (in) :: eps
    real(kind=qp), intent (in) :: xold, xnew, pold, pnew
    !double precision, intent (out) :: zz
    real(kind=qp), intent (out) :: zz
    integer :: i, maxit=100
    real(kind=qp) :: x1, x2, p1, p2, pz

    ! <doc>
    !  eps is declared as real on purpose.
    !  [see comment in find_zero_bisect_newton above.]
    ! </doc>

    x1 = xold
    x2 = xnew
    p1 = pold
    p2 = pnew

    if (debug) write (*,'(a,4es15.5e3)') 'initial ', x1, p1, x2, p2

    ! bisection
    do i=1, maxit
       zz = (x1+x2) * 0.5
       pz = laguerre_l(n,zz)
       if (abs(pz) <= eps) return
       if (pz*p1 < 0.) then
          p2=pz ; x2=zz
       else
          p1=pz ; x1=zz
       end if
       if (debug) write (*,'(a,6es25.15e3)') 'bisection ', x1, p1, x2, p2, pz, eps
    end do

    if (i==maxit+1) then
       ! newton-raphson
       if (zz==x1) x1 = x2
       do i=1, maxit
          x1 = zz
          p1 = dble(laguerre_l(n,x1))
          zz = x1 - p1 / dble(laguerre_lp(n,x1))
          pz = dble(laguerre_l(n,zz))
          if (debug) write (*,'(a,5es25.15e3)') &
               'newton ', zz, pz, x1, p1, eps
          if (min(abs(zz/x1-dble(1.0)), abs(pz)) < eps) exit
       end do

       if (i==maxit+1) then
          write (error_unit(),*) &
               & 'WARNING: too many iterations in get_laguerre_grids'

          stop 11
       end if
    end if

  end subroutine find_zero

  elemental function laguerre_l (n, x)

    integer, intent (in) :: n
    real(kind=qp), intent (in) :: x
    integer :: k
!    double precision :: laguerre_l, p, p1, p2
    real(kind=qp) :: laguerre_l, p, p1, p2

    p1 = dble(1.0) - x
    p2 = dble(1.0)

    if (n==0) then
       laguerre_l = p2
       return
    else if (n==1) then
       laguerre_l = p1
       return
    end if

    do k=2, n
       p = ((dble(2.0)*k-dble(1.0)-x) * p1 - (k-dble(1.0)) * p2) / k
       p2 = p1
       p1 = p
    end do

    laguerre_l = p

  end function laguerre_l

  elemental function laguerre_lp (n, x)

    integer, intent (in) :: n
    real(kind=qp), intent (in) :: x
    real(kind=qp) :: laguerre_lp

    laguerre_lp = n * (laguerre_l(n,x) - laguerre_l(n-1,x)) / x

  end function laguerre_lp

  subroutine check_laguerre_zeros (zero)

    use file_utils, only: error_unit
    use mp, only: mp_abort
    real, dimension (:), intent (in) :: zero
    logical :: error=.false.
    integer :: i, n

    n = size(zero)

    ! check positiveness
    if (any(zero <= 0.0)) then
       write (error_unit(),*) 'ERROR in laguerre: grid not positive'
       error = .true.
    end if

    ! check alignment
    if (any(zero(2:n)-zero(1:n-1) < 0.0)) then
       write (error_unit(),*) 'ERROR in laguerre: wrong alignment'
       error = .true.
    end if

    ! check distances are increasing
    do i=1, n-2
       if (zero(i+1)-zero(i) > zero(i+2)-zero(i+1)) then
          write (error_unit(),*) 'ERROR in laguerre: distances are decreasing at i= ', i
          error = .true.
       end if
    end do

    if (error) call mp_abort ('STOP in check_laguerre_zeros')

  end subroutine check_laguerre_zeros

  subroutine check_laguerre_weights (wgt, eps)

    use file_utils, only: error_unit
    use mp, only: mp_abort
    real, intent (in) :: eps
    real, dimension (:), intent (in) :: wgt
    logical :: error=.false.
    integer :: imax, n
    real :: s

    n = size(wgt)

    ! check if weights are all positive
    if (any(wgt <= 0.0)) then
       write (error_unit(),*) 'ERROR in laguerre: weights are not positive at n =', n
       error = .true.
    end if

    ! check if there is a single maximum
    imax = sum(maxloc(wgt))
    if (any(wgt(1:imax-1) > wgt(2:imax))) then
       write (error_unit(),*) 'ERROR in laguerre: weights decreasing before maximum'
       error = .true.
    end if
    if (any(wgt(imax:n-1) < wgt(imax+1:n))) then
       write (error_unit(),*) 'ERROR in laguerre: weights increasing after maximum'
       error = .true.
    end if

    ! check if their sum is close enough to normalized value
    if (debug) then
       s = sum(dble(wgt))
       if (abs(s-1.0) > eps) then
          write (error_unit(),*) 'WARNING in laguerre: weights summation incorrect:', &
               size(wgt), s
          ! Do not stop as it is mostly a minor issue
       end if
    end if

    if (error) call mp_abort ('STOP error in check_laguerre_weights')

  end subroutine check_laguerre_weights

end module gauss_quad


!*****************************************************************************************
!> author: Jacob Williams
!
!  Various matrix routines

    module matrix_module

    use kind_module,    only: wp
    use numbers_module, only: zero,one

    implicit none

    private

    public :: print_matrix
    public :: matrix_trace
    public :: matrix_determinant
    public :: matrix_cofactor

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

!*******************************************************************************
!>
!  Matrix determinant of an \( n \times n \) matrix (recursive formulation).
!
!### Reference
!  * https://rosettacode.org/wiki/Matrix_arithmetic#Fortran

    pure recursive function matrix_determinant(n,a) result(det)

    implicit none

    integer,intent(in)                  :: n   !! size of `a` matrix
    real(wp),dimension(n,n),intent(in)  :: a   !! the matrix
    real(wp)                            :: det !! the determinant of `a` matrix

    integer :: i   !! counter
    integer :: sgn !! `(-1)**(i-1)` term
    real(wp), dimension(n-1, n-1) :: b  !! temp matrix

    if (n == 1) then
        det = a(1,1)
    else
        det = zero
        sgn = 1
        do i = 1, n
            b(:, :(i-1)) = a(2:, :i-1)
            b(:, i:) = a(2:, i+1:)
            det = det + sgn * a(1, i) * matrix_determinant(n-1,b)
            sgn = -sgn
        end do
    end if

    end function matrix_determinant
!*******************************************************************************

!*******************************************************************************
!>
!  Compute the cofactors matrix (the transpose of the adjugate matrix).
!
!### References
!  * https://warwick.ac.uk/fac/sci/physics/research/condensedmatt/imr_cdt/students/david_goodwin/teaching/cis008-2/determinant_algorithm_cis008-2_lec_21.pdf
!  * https://groups.google.com/forum/#!topic/comp.lang.fortran/Y6jCv-QdDhc

    pure function matrix_cofactor (n,a) result(c)

    implicit none

    integer,intent(in)                  :: n   !! size of `a` matrix
    real(wp),dimension(n,n),intent(in)  :: a   !! the matrix
    real(wp),dimension(n,n)             :: c   !! the cofactors of `a` matrix

    integer :: i !! counter
    integer :: j !! counter
    real(wp),dimension(n-1,n-1) :: c_temp  !! temp matrix
    logical,dimension(n,n) :: m  !! mask for row/col removal

    if (n==1) then
        c(1,1) = one
    else
        do i=1,n
            do j=1,n
                ! remove the ith row and jth col from a:
                m = .true.
                m(:,j) = .false.
                m(i,:) = .false.
                c_temp = reshape(pack(a, m),[n-1,n-1])
                c(i,j) = ( (-1)**(i+j) ) * matrix_determinant(n-1,c_temp)
            end do
        end do
    end if

    end function matrix_cofactor
!*******************************************************************************

!*****************************************************************************************
!>
!  Print a matrix to the console.

    subroutine print_matrix(mat,unit)

    use iso_fortran_env, only: output_unit

    implicit none

    real(wp),dimension(:,:),intent(in) :: mat !! the matrix to print
    integer,intent(in),optional :: unit  !! unit number (assumed to be an open file).
                                         !! if not present, then the standard output is used.

    integer :: i      !! counter
    integer :: n      !! number of rows in the matrix
    integer :: iunit  !! the file unit to print to
    integer :: istat  !! `iostat` flag for write statement

    character(len=*),parameter :: fmt = 'E26.16'  !! real number format statement

    if (present(unit)) then
        iunit = unit
    else
        iunit = output_unit
    end if

    n = size(mat,1)

    do i=1,n
        write(iunit,fmt='(*('//fmt//',1X))',iostat=istat) mat(i,:)
    end do

    end subroutine print_matrix
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the matrix trace (sum of the diagonal elements).

    pure function matrix_trace(n,mat) result(trace)

    implicit none

    integer,intent(in)                 :: n     !! size of the matrix
    real(wp),dimension(n,n),intent(in) :: mat   !! the matrix
    real(wp)                           :: trace !! the matrix trace

    integer :: i !! counter

    trace = zero
    do i = 1, n
        trace = trace + mat(i,i)
    end do

    end function matrix_trace
!*****************************************************************************************

!*****************************************************************************************
    end module matrix_module
!*****************************************************************************************