subroutine HeteroAspirationUpdateRule(nodeUpdate, payoffUpdate, randNumUpdate)
    use global
    implicit none
    integer,intent(in)::nodeUpdate
    real(8),intent(in)::payoffUpdate
    real(8), intent(in)::randNumUpdate
    !!!
    real(8)::switchProbContributionUpdateFunction1
    real(8)::switchProbContributionUpdateFunction2
    real(8)::switchProbContributionUpdateFunction3
    real(8)::switchProb
    real(8)::AspirationMinusPayoffTimesSelectionIntensity
    real(8)::expBetaU
    !!
    AspirationMinusPayoffTimesSelectionIntensity = selectionIntensity * (aspirationValueNode(nodeUpdate, strategyGame(nodeUpdate) + 1) - payoffUpdate)
    expBetaU = exp(-AspirationMinusPayoffTimesSelectionIntensity)
    !!!! the variable u = selectionIntensity * (aspirationValue - payoff)
    !!!! base update function #1: 1 /(1 + exp(-u))
    !!!! base update function #2: 1 /(1 + 10*exp(-u))
    !!!! base update function #3: 1 /(1 + 0.1*exp(-u))
    !!!! each individual's update function is
    !!!! param1* baseUpdateFunction1 + param2* baseUpdateFunction2 + (1-param1-param2)*baseUpdateFunction3
    !!!! all update function parameters are in [0,1]
    switchProbContributionUpdateFunction1 = updateFunctionParams(nodeUpdate, 1) / (real(1.0,8) + expBetaU)
    switchProbContributionUpdateFunction2 = updateFunctionParams(nodeUpdate, 2) / (real(1.0,8) + real(10,8)*expBetaU)
    switchProbContributionUpdateFunction3 = (real(1.0,8)-updateFunctionParams(nodeUpdate, 1)-updateFunctionParams(nodeUpdate, 2)) / (real(1.0,8) + real(0.1,8)*expBetaU)
    !!!! calculating the switching probability
    switchProb = switchProbContributionUpdateFunction1 + switchProbContributionUpdateFunction2 + switchProbContributionUpdateFunction3
    !!!
    if(randNumUpdate < switchProb)then
        strategyGame(nodeUpdate) = 1 - strategyGame(nodeUpdate)
    end if

    return
end subroutine HeteroAspirationUpdateRule


#define type(x) TYPE(x), target

Module matrixAlgUtil_Mod
  ! Generic utilities for manipulating vectors and matrices

Contains

  Pure Function Vec2Matrix(vector)
    ! Converts tensors stored in vector format to a matrix format

    ! Arguments
    Double Precision, intent(IN) :: vector(:)

    ! Output
    Double Precision :: Vec2Matrix(3,3)

    ! Locals
    Double Precision, parameter :: zero=0.d0
    ! -------------------------------------------------------------------- !

    Vec2Matrix = zero
    Vec2Matrix(1,1) = vector(1)
    Vec2Matrix(2,2) = vector(2)
    Vec2Matrix(3,3) = Vector(3)
    Vec2Matrix(1,2) = vector(4)

    ! 2D or 3D
    If (size(vector) > 5) Then ! 3D
      Vec2Matrix(2,3) = vector(5)

      ! Symmetric or nonsymmetric
      If (size(vector) == 6) Then ! 3D, Symmetric
        Vec2Matrix(1,3) = vector(6)

        Vec2Matrix(2,1) = Vec2Matrix(1,2)
        Vec2Matrix(3,2) = Vec2Matrix(2,3)
        Vec2Matrix(3,1) = Vec2Matrix(1,3)

      Else ! 3D, Nonsymmetric
        Vec2Matrix(3,1) = vector(6)
        Vec2Matrix(2,1) = vector(7)
        Vec2Matrix(3,2) = vector(8)
        Vec2Matrix(1,3) = vector(9)
      End If

    Else ! 2D
      If (size(vector) == 5) Then  ! 2D, Nonsymmetric
        Vec2Matrix(2,1) = vector(5)
      Else                           ! 2D, Symmetric
        Vec2Matrix(2,1) = Vec2Matrix(1,2)
      End If
    End IF

    Return
  End Function Vec2Matrix

  Pure Function Matrix2Vec(mat, nshr, symmetric)
    ! Converts a symmetric tensor stored in matrix format (3,3) to a vector

    ! Arguments
    Double Precision, intent(IN) :: mat(3,3)
    Integer, intent(IN) :: nshr
    Logical, intent(IN), optional :: symmetric        ! True for symmetric matrix (default=True)

    ! Output
    Double Precision, allocatable :: Matrix2Vec(:)

    ! Locals
    Integer :: output_length
    Logical :: sym
    Double Precision, parameter :: zero=0.d0
    ! -------------------------------------------------------------------- !

    ! Optional argument for symmetry
    If (present(symmetric)) Then
      sym = symmetric
    Else
      sym = .TRUE.
    End If

    ! Initialize output
    If (sym) Then
      output_length = 3+nshr
    Else
      If (nshr == 1) Then
        output_length = 5
      Else
        output_length = 9
      End If
    End If
    Allocate(Matrix2Vec(output_length))
    Matrix2Vec = zero

    ! 2D components
    Do I=1,3; Matrix2Vec(I) = mat(I,I); End Do
    Matrix2Vec(4) = mat(1,2)

    ! 3D
    If (sym) Then
      If (nshr > 1) Then
        Matrix2Vec(5) = mat(2,3)
        Matrix2Vec(6) = mat(3,1)
      End If
    Else
      If (nshr > 1) Then
        Matrix2Vec(5) = mat(2,3)
        Matrix2Vec(6) = mat(3,1)
        Matrix2Vec(7) = mat(2,1)
        Matrix2Vec(8) = mat(3,2)
        Matrix2Vec(9) = mat(1,3)
      Else
        Matrix2Vec(5) = mat(2,1)
      End If
    End If

    Return
  End Function Matrix2Vec

  Pure Function VCmp(vec1, vec2)
    ! Checks if vec1 and vec2 have identical components
    ! Not optimized for large vectors

    ! Arguments
    Double Precision, intent(IN) :: vec1(:), vec2(:)

    ! Output
    Logical :: VCmp

    ! Locals
    Double Precision, parameter :: eps=1.d-30
    ! -------------------------------------------------------------------- !

    If(size(vec1) /= size(vec2)) Then
      VCmp = .FALSE.
      Return
    Else
      Do I=1, size(vec1)
        If(abs(vec1(I) - vec2(I)) > eps) Then
          VCmp = .FALSE.
          Return
        End If
      End Do
    End If

    VCmp = .TRUE.

    Return
  End Function VCmp

  Pure Function MInverse(mat)
    ! Finds the inverse of a 3x3 matrix

    ! Arguments
    Double Precision, intent(IN) :: mat(3,3)

    ! Output
    Double Precision :: MInverse(3,3)
    ! -------------------------------------------------------------------- !

    MInverse(1,1) = mat(3,3)*mat(2,2) - mat(3,2)*mat(2,3)
    MInverse(2,2) = mat(3,3)*mat(1,1) - mat(3,1)*mat(1,3)
    MInverse(3,3) = mat(1,1)*mat(2,2) - mat(1,2)*mat(2,1)

    MInverse(1,2) = -(mat(3,3)*mat(1,2) - mat(3,2)*mat(1,3))
    MInverse(2,1) = -(mat(3,3)*mat(2,1) - mat(2,3)*mat(3,1))
    MInverse(1,3) =   mat(2,3)*mat(1,2) - mat(2,2)*mat(1,3)
    MInverse(3,1) =   mat(3,2)*mat(2,1) - mat(2,2)*mat(3,1)
    MInverse(2,3) = -(mat(2,3)*mat(1,1) - mat(2,1)*mat(1,3))
    MInverse(3,2) = -(mat(3,2)*mat(1,1) - mat(1,2)*mat(3,1))

    Do I=1,3
      Do J=1,3
        MInverse(I,J) = MInverse(I,J) / MDet(mat)
      End Do
    End Do

    Return
  End Function MInverse

  Function MInverseLarge(mat)
    ! Finds the inverse of a matrix
    ! Requires LAPACK
    ! From: http://fortranwiki.org/fortran/show/inv

    ! Consider alternative for potential speed-up (TODO)
    ! https://caps.gsfc.nasa.gov/simpson/software/m66inv_f90.txt

    Use forlog_Mod

    ! Arguments
    Double Precision, intent(IN) :: mat(:,:)
    ! Output
    Double Precision :: MInverseLarge(size(mat,1),size(mat,2))

    ! Locals
    Double Precision :: work(size(mat,1))  ! work array for LAPACK
    Integer :: ipiv(size(mat,1))   ! pivot indices
    Integer :: n, out_info
    ! -------------------------------------------------------------------- !

    ! External procedures defined in LAPACK
    Interface
      Subroutine DGETRF(M, N, A, LDA, IPIV, INFO)
        ! http://www.math.utah.edu/software/lapack/lapack-d/dgetrf.html
        Integer, intent(IN) :: M, N, LDA
        Double Precision, intent(INOUT) :: A(LDA,N)
        Integer, intent(OUT) :: IPIV(size(A,1)), INFO
      End Subroutine DGETRF
      Subroutine DGETRI(N, A, LDA, IPIV, WORK, LWORK, INFO)
        ! http://www.math.utah.edu/software/lapack/lapack-d/dgetri.html
        Integer, intent(IN) :: N, LDA, LWORK
        Double Precision, intent(INOUT) :: A(LDA,N)
        Integer, intent(OUT) :: IPIV(size(A,1)), INFO
        Double Precision, intent(OUT) :: WORK(LWORK)
      End Subroutine DGETRI
    End Interface
    ! -------------------------------------------------------------------- !

    ! Store mat in MInverseLarge to prevent it from being overwritten by LAPACK
    MInverseLarge = mat
    n = size(mat,1)

    ! DGETRF computes an LU factorization of a general M-by-N matrix A
    ! using partial pivoting with row interchanges.
    Call DGETRF(n, n, MInverseLarge, n, ipiv, out_info)

    If (out_info /= 0) Then
      Call log%error('Matrix is numerically singular!')
    End If

    ! DGETRI computes the inverse of a matrix using the LU factorization
    ! computed by DGETRF.
    call DGETRI(n, MInverseLarge, n, ipiv, work, n, out_info)

    If (out_info /= 0) Then
      Call log%error('Matrix inversion failed!')
    End If

    Return
  End Function MInverseLarge

  Pure Function MInverse4x4(A) result(B)
    ! Credit for inversion algorithm goes to http://fortranwiki.org/fortran/show/Matrix+inversion
    ! Performs a direct calculation of the inverse of a 4x4 matrix.
    Double Precision, intent(in) :: A(4,4)   !! Matrix
    Double Precision             :: B(4,4)   !! Inverse matrix
    Double Precision             :: detinv

    ! Calculate the inverse determinant of the matrix
    detinv = &
      1/(A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))&
       - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))&
       + A(1,3)*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))&
       - A(1,4)*(A(2,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(2,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(2,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1))))

    ! Calculate the inverse of the matrix
    B(1,1) = detinv*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))
    B(2,1) = detinv*(A(2,1)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(2,3)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(2,4)*(A(3,3)*A(4,1)-A(3,1)*A(4,3)))
    B(3,1) = detinv*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
    B(4,1) = detinv*(A(2,1)*(A(3,3)*A(4,2)-A(3,2)*A(4,3))+A(2,2)*(A(3,1)*A(4,3)-A(3,3)*A(4,1))+A(2,3)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
    B(1,2) = detinv*(A(1,2)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(1,3)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(1,4)*(A(3,3)*A(4,2)-A(3,2)*A(4,3)))
    B(2,2) = detinv*(A(1,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(1,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(1,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))
    B(3,2) = detinv*(A(1,1)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(1,2)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(1,4)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
    B(4,2) = detinv*(A(1,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(1,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(1,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
    B(1,3) = detinv*(A(1,2)*(A(2,3)*A(4,4)-A(2,4)*A(4,3))+A(1,3)*(A(2,4)*A(4,2)-A(2,2)*A(4,4))+A(1,4)*(A(2,2)*A(4,3)-A(2,3)*A(4,2)))
    B(2,3) = detinv*(A(1,1)*(A(2,4)*A(4,3)-A(2,3)*A(4,4))+A(1,3)*(A(2,1)*A(4,4)-A(2,4)*A(4,1))+A(1,4)*(A(2,3)*A(4,1)-A(2,1)*A(4,3)))
    B(3,3) = detinv*(A(1,1)*(A(2,2)*A(4,4)-A(2,4)*A(4,2))+A(1,2)*(A(2,4)*A(4,1)-A(2,1)*A(4,4))+A(1,4)*(A(2,1)*A(4,2)-A(2,2)*A(4,1)))
    B(4,3) = detinv*(A(1,1)*(A(2,3)*A(4,2)-A(2,2)*A(4,3))+A(1,2)*(A(2,1)*A(4,3)-A(2,3)*A(4,1))+A(1,3)*(A(2,2)*A(4,1)-A(2,1)*A(4,2)))
    B(1,4) = detinv*(A(1,2)*(A(2,4)*A(3,3)-A(2,3)*A(3,4))+A(1,3)*(A(2,2)*A(3,4)-A(2,4)*A(3,2))+A(1,4)*(A(2,3)*A(3,2)-A(2,2)*A(3,3)))
    B(2,4) = detinv*(A(1,1)*(A(2,3)*A(3,4)-A(2,4)*A(3,3))+A(1,3)*(A(2,4)*A(3,1)-A(2,1)*A(3,4))+A(1,4)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)))
    B(3,4) = detinv*(A(1,1)*(A(2,4)*A(3,2)-A(2,2)*A(3,4))+A(1,2)*(A(2,1)*A(3,4)-A(2,4)*A(3,1))+A(1,4)*(A(2,2)*A(3,1)-A(2,1)*A(3,2)))
    B(4,4) = detinv*(A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)))

    Return
  End Function

  Pure Function MDet(mat)
    ! Finds the determinant of a 3x3 matrix

    ! Arguments
    Double Precision, intent(IN) :: mat(3,3)

    ! Output
    Double Precision :: MDet
    ! -------------------------------------------------------------------- !

    MDet = mat(1,1)*(mat(3,3)*mat(2,2) - mat(3,2)*mat(2,3)) - mat(2,1)*(mat(3,3)*mat(1,2) - mat(3,2)*mat(1,3)) + mat(3,1)*(mat(2,3)*mat(1,2) - mat(2,2)*mat(1,3))

    Return
  End Function MDet

  Pure Function OuterProduct(u, v)
    ! Calculates the outer product of two vectors

    ! Arguments
    Double Precision, intent(IN) :: u(:), v(:)

    ! Output
    Double Precision :: OuterProduct(size(u),size(v))
    ! -------------------------------------------------------------------- !

    Do I = 1, size(u)
      Do J = 1, size(v)
        OuterProduct(I,J) = u(I)*v(J)
      End Do
    End Do

    Return
  End Function OuterProduct

  Pure Function CrossProduct(a, b)
    ! Calculates the cross product of two vectors with length 3

    ! Arguments
    Double Precision, intent(IN) :: a(3), b(3)

    ! Output
    Double Precision :: CrossProduct(3)
    ! -------------------------------------------------------------------- !

    CrossProduct(1) = a(2)*b(3) - a(3)*b(2)
    CrossProduct(2) = a(3)*b(1) - a(1)*b(3)
    CrossProduct(3) = a(1)*b(2) - a(2)*b(1)

    Return
  End Function CrossProduct

  Pure Function Norm(u)
    ! Normalizes a vector

    ! Arguments
    Double Precision, intent(IN) :: u(:)

    ! Output
    Double Precision :: Norm(size(u))

    ! Locals
    Double Precision :: u_length
    ! -------------------------------------------------------------------- !

    u_length = Length(u)

    Do I = 1, size(u)
      Norm(I) = u(I)/u_length
    End Do

    Return
  End Function Norm

  Pure Function Length(u)
    ! Calculates the length of a vector

    ! Arguments
    Double Precision, intent(IN) :: u(:)

    ! Output
    Double Precision :: Length
    ! -------------------------------------------------------------------- !

    Length = 0.d0

    Do I = 1, size(u)
      Length = Length + u(I)*u(I)
    End Do

    Length = SQRT(Length)

    Return
  End Function Length

#ifndef PYEXT
  Subroutine PolarDecomp(F,R,U)
    ! Finds the polar decomposition of F
    ! Returns R and U

    ! Arguments
    Double Precision, intent(IN) :: F(3,3)
    Double Precision, intent(OUT) :: R(3,3), U(3,3)

    ! Locals
    Double precision :: eigVec(3,3), eigVal(3), WORK(1000), eigDiag(3,3)
    Double Precision :: Usquared(3,3)
    Integer :: INFO, LWORK
    Double Precision, parameter :: zero=0.d0
    ! -------------------------------------------------------------------- !

    ! Calculate U^2
    Usquared = MATMUL(TRANSPOSE(F), F)

    ! Get the eigenvalues and eigenvectors of U^2
    ! DSYEV is a LAPACK function; doc: http://www.netlib.org/lapack/double/dsyev.f
    eigVec = Usquared  ! prevent overwrite
    ! Setup workspace
    LWORK = -1
    Call DSYEV( 'V', 'U', 3, eigVec, 3, eigVal, WORK, LWORK, INFO )
    LWORK = MIN( 1000, INT( WORK( 1 ) ) )
    ! Solve the eigenvalue problem
    Call DSYEV( 'V', 'U', 3, eigVec, 3, eigVal, WORK, LWORK, INFO )
    If (info /= 0) Then
      print *, 'WARNING'
      print *, 'Failed to compute eigenvalues of U^2. DSYEV Error.'
    End If

    ! Get U
    eigDiag = zero
    eigDiag(1,1) = SQRT(eigVal(1))
    eigDiag(2,2) = SQRT(eigVal(2))
    eigDiag(3,3) = SQRT(eigVal(3))
    U = MATMUL(eigVec, MATMUL(eigDiag, TRANSPOSE(eigVec)))

    ! Get R
    R = MATMUL(F, MInverse(U))

    Return
  End Subroutine PolarDecomp
#endif

End Module


!****************************************************************************
!
!  PROGRAM: ODE1X1
!
!  PURPOSE:  Solve first-order, linear, ordinary differential equation using
!            Runge Kutta Method.
!
!****************************************************************************
!  Author: lcy
!
!  Data: 2019.09.27
!****************************************************************************

program ode1x1
!
! Numerical solution to the 1 x 1 ODE system by six
! integrators
!
! Double precision coding is used
implicit double precision(a-h,o-z)
!
! Size arrays
parameter(neq=500)
dimension u0(neq),u(neq)
!
! Open a file for output
no=2
open(no,file='ode1x1for.out')
!
! Step through six integrators
do ncase=1,6
!
! Integration parameters
    call intpar(neqn,nout,nsteps,t0,tf,abserr,relerr)
!
! Initial condition
    call inital(neqn,t0,u0)
!
! Output time
    tp=tf-t0
!
! Step through nout grid points
    do j=1,nout
!
! Print solution
        call fprint(no,ncase,neqn,t0,u0)
!
! Select ODE integrator
!
! Fixed step modified Euler integrator
        if(ncase.eq.1)then
            call euler2a(neqn,t0,tf,u0,nsteps,u)
        end if
!
! Variable step modified Euler integrator
        if(ncase.eq.2)then
            call euler2b(neqn,t0,tf,u0,nsteps,abserr,relerr,u)
        end if
!
! Fixed step classical fourth order RK integrator
        if(ncase.eq.3)then
            call rkc4a(neqn,t0,tf,u0,nsteps,u)
        end if
!
! Variable step classical fourth order RK integrator
        if(ncase.eq.4)then
            call rkc4b(neqn,t0,tf,u0,nsteps,abserr,relerr,u)
        end if
!
! Fixed step RK Fehlberg (RKF45) integrator
        if(ncase.eq.5)then
            call rkf45a(neqn,t0,tf,u0,nsteps,u)
        end if
!
! Variable step Fehlberg (RKF45) integrator
        if(ncase.eq.6)then
            call rkf45b(neqn,t0,tf,u0,nsteps,abserr,relerr,u)
        end if
!
! Advance solution
        t0=tf
        tf=tf+tp
        do i=1,neqn
            u0(i)=u(i)
        end do
!
! Next output
        end do
!
! Next integrator
        end do
!
! End of ode1x1
        end


program P2896
    implicit none
    real :: orange, apple, pine
    real :: i, j, k
    integer :: it, max

    real, dimension(3, 4) :: result

    read (*, *) orange, apple, pine
    read (*, *) i, j, k

    result(1, 1) = 0
    result(1, 2) = apple - orange * j / i
    result(1, 3) = pine - orange * k / i
    result(1, 4) = orange / i

    result(2, 1) = orange - apple * i / j
    result(2, 2) = 0
    result(2, 3) = pine - apple * k / j
    result(2, 4) = apple / j

    result(3, 1) = orange - pine * i / k
    result(3, 2) = apple - pine * j / k
    result(3, 3) = 0
    result(3, 4) = pine / k

    max = 1
    do it = 1, 3
        if (result(it, 1) < 0 .or. result(it, 2) < 0 .or. result(it, 3) < 0) then
            result(it, 4) = 0
        end if
        if (result(max, 4) < result(it, 4)) then
            max = it
        end if
    end do

    write (*, *) result(max, 1), result(max, 2), result(max, 3)
end program P2896


	REAL FUNCTION TSIZE(N)
	USE MSIMSL
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Sample size calculations involving t tests
C	This function evaluates the left hand side of equation (2) in
C	Dupont and Plummer (submitted for publication in 1992).  It is
C	used in conjunction with the iterative equation solver zero.
C	When TSIZE=0, N is the sample size needed to detect a true difference
C	DELTA with power 1-BETA and Type I error probability ALPHA.
C
C  Arguments:
C
C  Notes:
C   .	This routine was written by Dale Plummer
C   .	Designed by William Dupont
C
C-Declarations----------------------------------------------------------
C
C    Common used to pass needed values to passed name functions.
C
	INTEGER ITYPE
	REAL ALPHA, MYBETA, DELTA, M, NU
	COMMON /TSSCOMM/ALPHA, MYBETA, DELTA, M, NU, ITYPE

	INTEGER DFRESET
	COMMON /DFRESET/ DFRESET
C
C    Locals
C
	REAL N,TCRVALUE,T1,T2
C
C Code:
C
	IF (ITYPE.EQ.1) THEN
C
C    Paired t-test.
C
	    NU=N-1
	ELSE IF (ITYPE.EQ.2) THEN
C
C    Independent t-test
C
	    NU=N*(M+1)-2
	ELSE IF (ITYPE.EQ.3) THEN
C
C    Linear regression, number of treatments is 1.
C
	    NU=N-2
	ELSE IF (ITYPE.EQ.4) THEN
C
C    Linear regression, number of treatments is 2.
C
	    NU=N*(1+M)-4
	END IF
C
C    If NU (degrees of freedom) is less than 1 then we will be
C    hunting on an impossible curve.  In this case it makes sense
C    to go to the nearest possible curve, ie NU=1.  So if NU is
C    less that 1 then set it to 1.  Set the value DFRESET if we
C    do this.
C
	IF (NU.LT.1) THEN
		NU=1
		DFRESET=1
	END IF
C
C    Calculate the critical t value T1 such that pr[t>T1]=ALPHA/2
C    where t has a t distribution with NU degrees of freedom.
C
C	T1=TCRVALUE(ALPHA/2.,NU)
	T1=TIN((1.-ALPHA/2.),NU)
C	T2=TCRVALUE(MYBETA,NU)
	T2=TIN((1.-MYBETA),NU)
	TSIZE=(T1+T2)**2/DELTA**2-N
	RETURN
	END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_rot3_vec4gen
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the generators for a complex rotation represented
! by 3 real numbers: the real and imaginary parts of a complex cosine,
! CR and CI, and a scrictly real sine, S. The CR, CI and S are
! constructed to be parallel with the vector [AR+iAI,BR+iBI]^T, where AR,
! AI, BR and BI are real and i = sqrt(-1).
!
! This routine always adjusts the phase of [AR+iAI,BR+iBI]^T so that S >= 0.
!
! If any part of the input vector [AR+iAI,BR+iBI]^T contains a NAN then
! CR, CI, S and NRM are all set to NAN.
!
! If only one of AR, AI, BR or BI = +/-INF then the corresponding AR, AI, BR
! or BI is first set to +/-1 and the remaining terms are set to 0. Then the
! CR, CI and S are computed from the new vector containing +/-1 and 0. In
! this case NRM is always set to INF.
!
! If more than one of AR, AI, BR or BI = +/- INF then CR = CI = S = NRM = NAN
!
! If AR = AI = BR = BI = 0 then CR = 1, CI = S = 0 and NRM = 0.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! EXCEPTIONAL CASES
!
!    AR   |    AI   |    BR   |    BI   |    CR   |    CI   |    S    |   NRM
! ------- | ------- | ------- | ------- | ------- | ------- | ------- | -------
!   0d0   |   0d0   |   0d0   |   0d0   |   1d0   |   0d0   |   0d0   |   0d0
! ------- | ------- | ------- | ------- | ------- | ------- | ------- | -------
! +-INF   |   XdX   |   XdX   |   XdX   | +-1d0   |   0d0   |   0d0   |   INF
!   XdX   | +-INF   |   XdX   |   XdX   |   0d0   | +-1d0   |   0d0   |   INF
!   XdX   |   XdX   | +-INF   |   XdX   |   0d0   |   0d0   |   1d0   |   INF
!   XdX   |   XdX   |   XdX   | +-INF   |   0d0   |   0d0   |   1d0   |   INF
!          at least two +-INFs          |   NAN   |   NAN   |   NAN   |   NAN
! ------- | ------- | ------- | ------- | ------- | ------- | ------- | -------
!           at least one NAN            |   NAN   |   NAN   |   NAN   |   NAN
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  AR, AI          REAL(8)
!                    real and imaginary part of the first component
!                    of the complex vector [AR+iAI,BR+iBI]^T
!
!  BR, BI          REAL(8)
!                    the second component
!                    of the complex vector [AR+iAI,BR+iBI]^T
!
! OUTPUT VARIABLES:
!
!  CR, CI          REAL(8)
!                    on exit CR = AR/NRM, CI = AI/NRM
!
!  S               REAL(8)
!                    on exit S = B/NRM
!
!  NRM             REAL(8)
!                    on exit contains the norm
!                    of the complex vector [AR+iAI,BR+iBI]^T
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_rot3_vec4gen(AR,AI,BR,BI,CR,CI,S,NRM)

  implicit none

  ! input variables
  real(8), intent(in) :: AR, AI, BR, BI
  real(8), intent(inout) :: CR, CI, S, NRM

  ! compute variables
  real(8), parameter :: inf = EISCOR_DBL_INF
  real(8) :: pAr, pAi, pBr, pBi

  ! compute phase of BR, BI
  call d_rot2_vec2gen(BR,BI,pBr,pBi,S)

  ! compute phase of AR, AI
  call d_rot2_vec2gen(AR,AI,pAr,pAi,CR)

  ! check if AR is the only INF
  if ((abs(S)<=inf).AND.(abs(CR)>inf).AND.(pAr.EQ.0d0)) then

    ! construct CR, CI, S
    call z_rot3_vec3gen(AR,AI,S,CR,CI,S,NRM)

  ! check if AI is the only INF
  else if ((abs(S)<=inf).AND.(abs(CR)>inf).AND.(pAi.EQ.0d0)) then

    ! construct CR, CI, S
    call z_rot3_vec3gen(AR,AI,S,CR,CI,S,NRM)

  ! otherwise
  else

    ! adjust phase of AR, AI and BR, BI so that BR = sqrt(|BR|^2 + |BI|^2) and BI = 0
    call d_rot2_vec2gen(pAr*pBr + pAi*pBi,-pAr*pBi + pAi*pBr,pAr,pAi,CI)

    ! construct CR, CI, S
    call z_rot3_vec3gen(CR*pAr,CR*pAi,S,CR,CI,S,NRM)

  end if

end subroutine z_rot3_vec4gen


        subroutine LegendreSP(Plm,x)

*************************************************************************
**  Written by Lin-Wang Wang, 2003
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

cccc Plm(m,l)[x]=sqrt[(2*l+1)/4pi*(l-m)!/(l+m)!] P_l^m(x)
cccc  here, P_l^m(x) is the Lengendre function

cccc Note the normalized spherical harmonic function is:
cccc Y_lm(th,phi)=Plm(m,l)[costh]*exp(i*m*phi)

        implicit double precision(a-h,o-z)
        parameter (pi=3.14159265358979312d0)
        real*8 plm(-6:6,0:6),F(-6:6,0:6)

ccccccc   F(m,l)=d^(l+m)/dx^(l+m) (x^2-1)^l
        x2=x**2
        x3=x2*x
        x4=x3*x
        x5=x4*x
        x6=x5*x
        x7=x6*x
        x8=x7*x
        x9=x8*x
        x10=x9*x
        x11=x10*x
        x12=x11*x

        F(0,0)=1.d0

        F(-1,1)=x2-1
        F(0,1)=2*x
        F(1,1)=2

        F(-2,2)=x4-2*x2+1
        F(-1,2)=4*x3-4*x
        F(0,2)=12*x2-4
        F(1,2)=24*x
        F(2,2)=24

        F(-3,3)=x6-3*x4+3*x2-1
        F(-2,3)=6*x5-12*x3+6*x
        F(-1,3)=30*x4-36*x2+6
        F(0,3)=120*x3-72*x
        F(1,3)=360*x2-72
        F(2,3)=720*x
        F(3,3)=720

        F(-4,4)=x8-4*x6+6*x4-4*x2+1
        F(-3,4)=8*x7-24*x5+24*x3-8*x
        F(-2,4)=56*x6-120*x4+72*x2-8
        F(-1,4)=336*x5-480*x3+144*x
        F(0,4)=1680*x4-1440*x2+144
        F(1,4)=6720*x3-2880*x
        F(2,4)=20160*x2-2880
        F(3,4)=40320*x
        F(4,4)=40320

        F(-5,5)=x10-5*x8+10*x6-10*x4+5*x2-1
        F(-4,5)=10*x9-40*x7+60*x5-40*x3+10*x
        F(-3,5)=90*x8-280*x6+300*x4-120*x2+10
        F(-2,5)=720*x7-1680*x5+1200*x3-240*x
        F(-1,5)=5040*x6-8400*x4+3600*x2-240
        F(0,5)=30240*x5-33600*x3+7200*x
        F(1,5)=151200*x4-100800*x2+7200
        F(2,5)=604800*x3-201600*x
        F(3,5)=1814400*x2-201600
        F(4,5)=3628800*x
        F(5,5)=3628800

        F(-6,6)=x12-6*x10+15*x8-20*x6+15*x4-6*x2+1
        F(-5,6)=12*x11-60*x9+120*x7-120*x5+60*x3-12*x
        F(-4,6)=132*x10-540*x8+840*x6-600*x4+180*x2-12
        F(-3,6)=1320*x9-4320*x7+5040*x5-2400*x3+360*x
        F(-2,6)=11880*x8-30240*x6+25200*x4-7200*x2+360
        F(-1,6)=95040*x7-181440*x5+100800*x3-14400*x
        F(0,6)=665280*x6-907200*x4+302400*x2-14400
        F(1,6)=3991680*x5-3628800*x3+604800*x
        F(2,6)=19958400*x4-10886400*x2+604800
        F(3,6)=79833600*x3-21772800*x
        F(4,6)=239500800*x2-21772800
        F(5,6)=479001600*x
        F(6,6)=479001600

        Plm(0,0)=1.d0/dsqrt(4*pi)

        do l=1,6
        call factorial(ifact,l)

        Plm(0,l)=1.d0/2.d0**l/ifact*F(0,l)

        do m=1,l
        isign=-1
        if(mod(m,2).eq.0) isign=1
        Plm(m,l)=isign/2.d0**l/ifact*
     &       (1-x**2)**(m/2.d0)*F(m,l)    ! this is the Legendre func.

        call factorial(ifact1,l-m)
        call factorial(ifact2,l+m)

        Plm(m,l)=dsqrt((2*l+1.d0)*ifact1/(4*pi*ifact2))*
     &      Plm(m,l)

        Plm(-m,l)=isign*Plm(m,l)
        enddo

        enddo

        return
        contains

        subroutine factorial(ifact_tmp,ii)
        implicit double precision (a-h,o-z)
        integer ifact_tmp,ii

        if(ii.eq.0)  then
        ifact_tmp=1
        endif

        if(ii.gt.0) then
        ifact_tmp=1
        do i=1,ii
        ifact_tmp=ifact_tmp*i
        enddo
        endif

        return
        end subroutine factorial

        end


!-----Area_Circle----------------------------------------------------
!
!  Function to compute the area of a circle of given radius
!
!---------------------------------------------------------------------

FUNCTION Area_Circle(r)

IMPLICIT NONE
REAL :: Area_Circle
REAL, INTENT(IN) :: r

! Declare local constant Pi
REAL, PARAMETER :: Pi = 3.1415927

Area_Circle = Pi * r * r

END FUNCTION Area_Circle

PROGRAM Area
!---------------------------------------------------------------------
!
!  This program computes the area of a circle given the input radius
!
!  Uses:  FUNCTION Area_Circle (r)
!
!---------------------------------------------------------------------
IMPLICIT NONE

INTERFACE
!   FUNCTION Area_Circle (r)
!     REAL, Area_Circle
!     REAL, INTENT(IN) :: r
!   END FUNCTION Area_Circle
END INTERFACE

! Declare local variables
REAL :: radius

WRITE(*,*) "Calculating circle area"
WRITE(*,*) Area_Circle(2)

!  Prompt user for radius of circle
!write(*, '(A)', ADVANCE = "NO") "Enter the radius of the circle:  "
!read(*,*) radius

! Write out area of circle using function call
!write(*,100) "Area of circle with radius", radius, " is", &
!            Area_Circle(radius)
!100 format (A, 2x, F6.2, A, 2x, F11.2)

END PROGRAM


c     plate - a prompt-driven routine for laminated plate calculations
dimension S(3,3),Sbar(3,3),Qbar(3,3),E(6,7),kwa(6),
*          T(3,3),Tinv(3,3),R(3,3),Rinv(3,3),Et(6,6),
*          temp1(3,3),temp2(3,3),temp3(3,3),
*          eps0(3),xkappa(3),sigbar(3),sig(3),vtemp1(3),
*          vtemp2(3),E1(10),E2(10),Gnu12(10),G12(10),thk(10),
*          z(21),mat(20),theta(20),Qsave(3,3,20),Tsave(3,3,20)
data R/1.,3*0.,1.,3*0.,2./,Rinv/1.,3*0.,1.,3*0.,.5/,
*     E/42*0./
c----------------------------------------------------------------------
c     input material set selections
i=1
10    write(6,20) i
20    format (' assign properties for lamina type ',i2,'...'/)
write(6,*) 'enter modulus in fiber direction...'
write(6,*) '   (enter -1 to stop): '
read (5,*) E1(i)
if (E1(i) .lt. 0.) go to 30
write(6,*) 'enter modulus in transverse direction: '
read (5,*) E2(i)
write(6,*) 'enter principal Poisson ratio: '
read (5,*) Gnu12(i)
c        check for isotropy
check=abs((E1(i)-E2(i))/E1(i))
if (check.lt.0.001) then
G12(i)=E1(i)/(2.*(1.+Gnu12(i)))
else
write(6,*) 'enter shear modulus: '
read (5,*) G12(i)
end if
write(6,*) 'enter ply thickness: '
read (5,*) thk(i)
i=i+1
go to 10
c----------------------------------------------------------------------
c     define layup
30    iply=1
z(1)=0.
write(6,*) 'define layup sequence, starting at bottom...'
write(6,*) '   (use negative material set number to stop)'
40    write (6,50) iply
50    format (/' enter material set number for ply number',i3,': ')
read (5,*) m
if (m.lt.0) go to 60
mat(iply)=m
write(6,*) 'enter ply angle: '
read (5,*) theta(iply)
z(iply+1)=z(iply)+thk(m)
iply=iply+1
go to 40
c     compute boundary coordinates (measured from centerline)
60    thick=z(iply)
N = iply-1
z0 = thick/2.
np1=N+1
do 70 i=1,np1
z(i)=z(i)-z0
70    continue
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c     loop over plies, form stiffness matrix
do 110 iply=1,N
m=mat(iply)
c        form lamina compliance in 1-2 directions (Eqn. 3.55)
S(1,1) = 1./E1(m)
S(2,1) = -Gnu12(m) / E1(m)
S(3,1) = 0.
S(1,2) = S(2,1)
S(2,2) = 1./E2(m)
S(3,2) = 0.
S(1,3) = 0.
S(2,3) = 0.
S(3,3) = 1./G12(m)
c----------------------------------------------------------------------
c        transform to x-y axes
c        obtain transformation matrix T (Eqn. 3.27)
thet = theta(iply) * 3.14159/180.
sc = sin(thet)*cos(thet)
s2 = (sin(thet))**2
c2 = (cos(thet))**2
T(1,1) = c2
T(2,1) = s2
T(3,1) = -1.*sc
T(1,2) = s2
T(2,2) = c2
T(3,2) = sc
T(1,3) = 2.*sc
T(2,3) = -2.*sc
T(3,3) = c2 - s2
c        inverse transformation matrix
Tinv(1,1) = c2
Tinv(2,1) = s2
Tinv(3,1) = sc
Tinv(1,2) = s2
Tinv(2,2) = c2
Tinv(3,2) = -1.*sc
Tinv(1,3) = -2.*sc
Tinv(2,3) = 2.*sc
Tinv(3,3) = c2 - s2
c        transformation [Sbar] = [R][T]-1[R]-1[S][T] (Eqn. 3.56)
call matmul (3,3,3,3,3,3,R,Tinv,temp1)
call matmul (3,3,3,3,3,3,temp1,Rinv,temp2)
call matmul (3,3,3,3,3,3,temp2,S,temp3)
call matmul (3,3,3,3,3,3,temp3,T,Sbar)
c----------------------------------------------------------------------
c        invert Sbar (transformed compliance matrix) to obtain
c               Qbar (transformed stiffness matrix)
c        start by setting Qbar = Sbar, then call inversion routine
do 80 i=1,3
do 80 j=1,3
Qbar(i,j)=Sbar(i,j)
80       continue
call matinv(isol,idsol,3,3,Qbar,3,kwa,det)
c        save Qbar and Tinv matrices
do 90 i=1,3
do 90 j=1,3
Qsave(i,j,iply)=Qbar(i,j)
Tsave(i,j,iply)=Tinv(i,j)
90       continue
c        add to laminate stiffness matrix
ip1=iply+1
z1=        (z(ip1)   -z(iply)   )
z2=    0.5*(z(ip1)**2-z(iply)**2)
z3=(1./3.)*(z(ip1)**3-z(iply)**3)
do 100 i=1,3
do 100 j=1,3
E(i,j)    =  E(i,j) +     Qbar(i,j)*z1
xx        =               Qbar(i,j)*z2
E(i+3,j)  =  E(i+3,j) +   xx
E(i,j+3)  =  E(i,j+3) +   xx
E(i+3,j+3)=  E(i+3,j+3) + Qbar(i,j)*z3
100      continue
c     end loop over plies; stiffness matrix now formed
110   continue
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c     output stiffness matrix
write(6,120)
120   format(/' laminate stiffness matrix:',/)
do 140 i=1,6
write(6,130) (e(i,j),j=1,6)
130      format (4x,3e12.4,2x,3d12.4)
if (i.eq.3) write(6,*)
140   continue
c----------------------------------------------------------------------
c     obtain and print laminate compliance matrix
c      do 300 i=1,6
c      do 300 j=1,6
c         Et(i,j)=E(i,j)
c300   continue
c      call matinv(isol,idsol,6,6,Et,6,kwa,det)
c      write(6,310)
c310   format(/' laminate compliance matrix:',/)
c      do 320 i=1,6
c         write(6,130) (Et(i,j),j=1,6)
c         if (i.eq.3) write(6,*)
c320   continue
c----------------------------------------------------------------------
c     obtain traction-moment vector
write(6,*)
write(6,*) 'input tractions and moments...'
write(6,*)
write(6,*) '   Nx: '
read (5,*) e(1,7)
write(6,*) '   Ny: '
read (5,*) e(2,7)
write(6,*) '  Nxy: '
read (5,*) e(3,7)
write(6,*) '   Mx: '
read (5,*) e(4,7)
write(6,*) '   My: '
read (5,*) e(5,7)
write(6,*) '  Mxy: '
read (5,*) e(6,7)
c----------------------------------------------------------------------
c     solve resulting system; print strains and rotations
call matinv(isol,idsol,6,7,e,6,kwa,det)
write(6,150) (e(i,7),i=1,6)
150   format(/' midplane strains:',//3x,'eps-xx =',e12.4,
*   /3x,'eps-yy =',e12.4,/3x,'eps-xy =',e12.4,
*   //' rotations:',//3x,'kappa-xx =',e12.4,
*   /3x,'kappa-yy= ',e12.4,/3x,'kappa-xy =',e12.4//)
c----------------------------------------------------------------------
c     compute ply stresses
write(6,160)
160   format (/' stresses:',/2x,'ply',5x,'sigma-1',
*        5x,'sigma-2',4x,'sigma-12'/)
do 210 iply=1,N
do 180 i=1,3
eps0(i)=e(i,7)
xkappa(i)=e(i+3,7)
do 170 j=1,3
Qbar(i,j)=Qsave(i,j,iply)
Tinv(i,j)=Tsave(i,j,iply)
170         continue
180      continue
call matmul (3,3,3,3,3,1,Qbar,eps0,vtemp1)
call matmul (3,3,3,3,3,1,Qbar,xkappa,vtemp2)
zctr=(z(iply)+z(iply+1))/2.
do 190 i=1,3
sigbar(i) = vtemp1(i) + zctr*vtemp2(i)
190      continue
call matmul (3,3,3,3,3,1,Tinv,sigbar,sig)
write(6,200) iply,sig
200      format (3x,i2,3e12.4)
210   continue
stop
end
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c --------  library routines for matrix operations -----------
subroutine matmul(lra,lrb,lrc,i,j,k,a,b,c)
c
c     this subroutine performs the multiplication of two
c     two-dimensional matrices (a(i,j)*b(j,k) = c(i,k)).
c
c     lra - row dimension of "a" (multiplier) matrix
c     lrb - row dimension of "b" (multiplicand) matrix
c     lrc - row dimension of "c" (product) matrix
c     i   - actual number of rows in "a"
c     j   - actual number of columns in "a"
c     k   - actual number of columns in "b"
c     a   - multiplier
c     b   - multiplicand
c     c   - product
dimension a(1), b(1), c(1)
do 20 l = 1,i
nm1 = 0
lm = l
do 20 m = 1,k
c(lm) = 0.0
nm = nm1
ln = l
do 10 n = 1,j
nm = nm + 1
c(lm) = c(lm) + a(ln)*b(nm)
10   ln = ln + lra
nm1 = nm1 + lrb
20   lm = lm + lrc
return
end
subroutine matinv(isol,idsol,nr,nc,a,mra,kwa,det)
c
c     this subroutine finds the inverse and/or solves
c     simultaneous equations, or neither, and
c     calculates a determinant of a real matrix.
c
c     isol - communications flag (output)
c        1 - inverse found or equations solved
c        2 - unable to solve
c        3 - input error
c     idsol - determinant calculation flag (output)
c        1 - did not overflow
c        2 - overflow
c     nr - number of rows in input matrix "a"
c     nc - number of columns in "a"
c     a  - input matrix, first "nr" columns will be inverted
c             on output, "a" is converted to a-inverse
c     mra - row dimension of "a" matrix
c     kwa - work array
c     det - value of determinant (if idsol = 1)
dimension a(1), kwa(1)
ir = nr
isol = 1
idsol = 1
if(nr.le.0) go to 330
if((ir-mra).gt.0) go to 330
ic = iabs(nc)
if ((ic - ir).lt.0) ic = ir
ibmp = 1
jbmp = mra
kbmp = jbmp + ibmp
nes = ir*jbmp
net = ic*jbmp
if(nc) 10,330,20
10   mdiv = jbmp + 1
iric = ir - ic
go to 30
20   mdiv = 1
30   mad = mdiv
mser = 1
kser = ir
mz = 1
det = 1.0
40   piv = 0.
i = mser
50   if (( i - kser).gt.0) go to 70
if((abs(a(i))-piv).le.0.) go to 60
piv = abs(a(i))
ip = i
60   i = i + ibmp
go to 50
70   if(piv.eq.0.) go to 340
if(nc.lt.0) go to 80
i = ip-((ip - 1)/jbmp)*jbmp
j = mser - ((mser - 1)/jbmp)*jbmp
jj = mser/kbmp + 1
ii = jj + (ip -mser)
kwa(jj) = ii
go to 90
80   i = ip
j = mser
90   if (ip - mser) 330,120,100
100  if ((j - net).gt.0) go to 110
psto = a(i)
a(i) = a(j)
a(j) = psto
i = i + jbmp
j = j + jbmp
go to 100
110  det = - det
120  psto = a(mser)
det = det*psto
130  if (det.eq.0.) goto 150
140  psto = 1./psto
go to 160
150  idsol = 1
isol = 2
return
160  continue
a(mser) = 1.0
i = mdiv
170  if((i - net).gt.0) go to 180
a(i) = a(i)*psto
i = i + jbmp
go to 170
180  if((mz - kser).gt.0) go to 210
if((mz-mser).eq.0) go to 200
i = mad
j = mdiv
psto = a(mz)
if(psto.eq.0.) go to 200
a(mz) = 0.
190  if((j-net).gt.0) go to 200
a(i) = a(i) - a(j)*psto
j = j + jbmp
i = i + jbmp
go to 190
200  mad = mad + ibmp
mz = mz + ibmp
go to 180
210 continue
c 210  need a test here.....call overfl(ivf)
c      go to (350,220),ivf
ccccccc  need at test here, anyhow
220  kser = kser + jbmp
if ((kser-nes).gt.0) go to 260
mser = mser + kbmp
if(nc.lt.0) go to 230
mdiv = mdiv + ibmp
mz = ((mser - 1)/jbmp)*jbmp + 1
mad = 1
go to 40
230  mdiv = mdiv + kbmp
if(iric.ne.0) go to 240
mz = mser + ibmp
go to 250
240  mz = ((mser - 1)/jbmp)*jbmp + 1
250  mad = mz + jbmp
go to 40
260  if(nc.lt.0) return
jr = ir
270  if(jr) 330,360,280
280  if(kwa(jr) - jr) 330,320,290
290  k = (jr - 1)*jbmp
j = k + ir
l = (kwa(jr) - 1)*jbmp + ir
300  if(j - k) 330,320,310
310  psto = a(l)
a(l) = a(j)
a(j) = psto
j = j - ibmp
l = l - ibmp
go to 300
320  jr = jr - 1
go to 270
330  isol = 3
return
340  det = 0.
isol = 2
idsol = 1
return
350  isol = 2
idsol = 2
360  return
end


c     ============================================
      subroutine diffuse_u(maxmx,mbc,mx,meqn,q,
     &            xlower,dx,t,dt)
c     ============================================

      implicit none
      double precision q(1-mbc:maxmx+mbc, meqn)

      integer maxmx,mbc,mx,meqn,maux
      double precision xlower,dx,t,dt

*     !local variables
      integer MXMAX,i
      parameter (MXMAX=5000)
      double precision visc,rk
      double precision r(1:MXMAX),u(1:MXMAX)

      include "digparamsdec.i"
      include "digparamscommon.i"
      return
      if (mx.gt.MXMAX) then
         write(*,*) 'diffuse_u: increase MXMAX to: ', mx
         stop
      endif

      visc = m0*mu
      rk = visc/(2.d0*dx**2)
      do i = 1,mx
         if (q(i,1).gt.dry_tol) then
            u(i) = q(i,2)/q(i,1)
         else
            u(i) = 0.d0
         endif
      enddo
      r(1)  = (1.d0-rk)*u(1) + rk*u(2)
      r(mx) = (1.d0-rk)*u(mx) + rk*u(mx-1)

      do i = 2,mx-1
         r(i) = rk*u(i-1) + (1.d0-2.d0*rk)*u(i) + rk*u(i+1)
      enddo

      call cranknicholson(u(1:mx),r(1:mx),rk,mx)

      do i = 1,mx
         q(i,2) = u(i)*q(i,1)
      enddo
      do i=1,mbc
         q(1-i,2) = q(1,2)
         q(mx+i,2) = q(mx,2)
      enddo

      return
      end

c     ------------------------------------------------------------------
      subroutine cranknicholson(u,r,rk,n)
c     ------------------------------------------------------------------

      integer n,NMAX
*     !i/o
      double precision a,b,c,rk,u(n),r(n)
*     !i/o
      PARAMETER (NMAX = 5000)
      integer j
      double precision bet,gam(NMAX)

      a = -rk
      b = 1.d0+2.d0*rk
      c = -rk

      bet = 1.d0 + rk!b
      u(1) = r(1)/bet

      do j = 2,n
         gam(j) = c/bet
         bet = b - a*gam(j)
         if (j.eq.n) bet = bet - rk
         if (bet.eq.0.) then
            write(*,*) 'tridiag failed'
            stop
         endif
         u(j) = (r(j)-a*u(j-1))/bet
      enddo

      do j = n-1,1,-1
         u(j) = u(j) - gam(j+1)*u(j+1)
      enddo

      return
      end


module Samples
    use Const
    implicit none
contains
    function linear2(t, X) result(dX)
        real(mpc) :: t, X(2), dX(size(X))
        intent(in) :: t, X
        dX(1) =  -X(2)
        dX(2) =  X(1)
    end function linear2
    function sol_linear2(t) result(X)
        real(mpc), intent(in) :: t
        real(mpc), dimension(2) :: X
        X(1) = cos(t) - sin(t)
        X(2) = sin(t) + cos(t)
    end function sol_linear2
    function linear2_nhom(t, X) result(dX)
        real(mpc) :: t, X(2), dX(size(X))
        intent(in) :: t, X
        dX(1) =  3.0_mpc*X(1) + 2.0_mpc*X(2) + sin(t)
        dX(2) = -5.0_mpc*X(1) + 1.0_mpc*X(2) + exp(-t)
    end function linear2_nhom
    function sol_linear2_nhom(t) result(X)
        real(mpc), intent(in) :: t
        real(mpc), dimension(2) :: X
        X(1) = exp(2*t)*(53.0*sin(3*t)/45.0+151.0*cos(3*t)/180.0)-sin(t)/10.0+co&
            &s(t)/20.0+exp(-t)/9.0
        X(2) = exp(2*t)*((-133.0)*sin(3*t)/72.0+97.0*cos(3*t)/72.0)+(-3.0)*sin(t&
            &)/8.0-cos(t)/8.0+(-2.0)*exp(-t)/9.0
    end function sol_linear2_nhom
end module Samples


!dis
!dis    Open Source License/Disclaimer, Forecast Systems Laboratory
!dis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
!dis
!dis    This software is distributed under the Open Source Definition,
!dis    which may be found at http://www.opensource.org/osd.html.
!dis
!dis    In particular, redistribution and use in source and binary forms,
!dis    with or without modification, are permitted provided that the
!dis    following conditions are met:
!dis
!dis    - Redistributions of source code must retain this notice, this
!dis    list of conditions and the following disclaimer.
!dis
!dis    - Redistributions in binary form must provide access to this
!dis    notice, this list of conditions and the following disclaimer, and
!dis    the underlying source code.
!dis
!dis    - All modifications to this software must be clearly documented,
!dis    and are solely the responsibility of the agent making the
!dis    modifications.
!dis
!dis    - If significant modifications or enhancements are made to this
!dis    software, the FSL Software Policy Manager
!dis    (softwaremgr@fsl.noaa.gov) should be notified.
!dis
!dis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
!dis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
!dis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
!dis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
!dis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
!dis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
!dis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
!dis
!dis

  SUBROUTINE interp_press_to_z(press_levels, heights, new_level, press_out, &
                                  nx,ny,nz)

    ! Given a 1D array of pressure levels and a 3D array of heights (m) at
    ! those levels, this routine interpolates the pressure to the desired
    ! new_level.

    ! Pressures are in Pa, heights are in m!

    IMPLICIT NONE
    INTEGER, INTENT(IN)               :: nx,ny,nz
    REAL, INTENT(IN)                  :: press_levels(nz)
    REAL, INTENT(IN)                  :: heights(nx,ny,nz)
    REAL, INTENT(IN)                  :: new_level
    REAL, INTENT(OUT)                 :: press_out (nx,ny)
    INTEGER                           :: i,j,k, ktop
    REAL                              :: ptop,pbot,ztop,zbot

    nsloop: DO j = 1, ny
      ewloop: DO i = 1, nx
        vertloop: DO k = 2, nz
          IF (heights(nx,ny,nz) .ge. new_level) THEN
             ktop = k
             EXIT vertloop
          ENDIF
        ENDDO vertloop
        ztop = heights(i,j,k)
        zbot = heights(i,j,k-1)
        ptop = press_levels(k)*0.01    ! Convert to mb!
        pbot = press_levels(k-1)*0.01
        press_out(i,j) = EXP ( &
                              ( new_level*ALOG(pbot/ptop) - &
                              ztop*ALOG(pbot) + &
                              zbot*ALOG(ptop)  ) / &
                              (zbot - ztop) ) * 100.  ! convert back to Pa
      ENDDO ewloop
    ENDDO nsloop
    RETURN
  END SUBROUTINE interp_press_to_z


program test_eigenvectors
  !! Program to show the usage of the the *eigenvectors* module.
        use eigenvectors
        implicit none
        integer, parameter :: N = 3
        integer :: i
        real :: A(N,N), v(N), lambda1, lambda2, lambda3
        character(:), allocatable :: fmt

        fmt = '(F7.2)'

        A(1,:) = [ 1., 0., 0. ]
        A(2,:) = [ 0., -0.5, 0. ]
        A(3,:) = [ 0., 0., -4.]

        call eigen_max(A, v, lambda1, maxIter= 1000, err_v=1.E-6, v_0=[1.,1.,1.])
        print*, "biggest eigenvalue: "
        write(*,fmt=fmt) lambda1
        print*, "associated eigenvector: "
        do i = 1,N
          write(*,fmt=fmt) v(i)
        end do

        call eigen_inv(A, v, lambda1, maxIter= 1000, p=0., err_v=1.E-6, v_0=[1.,1.,1.])
        print*, "smallest eigenvalue: "
        write(*,fmt=fmt) lambda1
        print*, "associated eigenvector: "
        do i = 1,N
          write(*,fmt=fmt) v(i)
        end do

end program


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine tridiagonal_nrhs(a,b,n,m,nrhs)
!
!     solves a tridiagonal system of equations A*x=b with
!     n equations. The off-diagonals are in symmetric positions
!     about the main diagonal and m entries away; the matrix does
!     not have to be symmetric
!
!     the first line contains the elements A(1,1) and A(1,1+m)
!     the last line contains the elements A(n,n-m),A(n,n)
!     (assuming full storage mode)
!
!     tridiagonal storage:
!       left diagonal in a(1,*)
!       main diagonal in a(2,*)
!       right diagonal in a(3,*)
!
!     INPUT:
!
!     a                  tridiagonal matrix
!     b                  right hand side
!     n                  number of rows and columns of a
!     m                  shift of the off-diagonals compared
!                        to the main diagonal
!     nrsh               number of right hand sides
!
!     OUTPUT
!
!     b                  solution
!
      implicit none
!
      integer i,k,n,m,nrhs
!
      real*8 a(3,n),b(nrhs,n),y
!
      intent(in) n,m,nrhs
!
      intent(inout) a,b
!
!     Gaussian elimination: all values below the
!     diagonal are set to zero, the diagonal values set to 1
!
!     only the unknown values a(3,*) and b(nrhs,*) are calculated
!
      do k=1,m
         a(3,k)=a(3,k)/a(2,k)
         do i=1,nrhs
            b(i,k)=b(i,k)/a(2,k)
         enddo
      enddo
!
      do k=m+1,n-m
         y=1.d0/(a(3,k-m)*a(1,k)-a(2,k))
         a(3,k)=-a(3,k)*y
         do i=1,nrhs
            b(i,k)=(b(i,k-m)*a(1,k)-b(i,k))*y
         enddo
      enddo
!
      do k=n-m+1,n
         a(2,k)=a(3,k-m)*a(1,k)-a(2,k)
         do i=1,nrhs
            b(i,k)=(b(i,k-m)*a(1,k)-b(i,k))/a(2,k)
         enddo
      enddo
!
!     back substitution
!
      do k=n-m,1,-1
         do i=1,nrhs
            b(i,k)=b(i,k)-a(3,k)*b(i,k+m)
         enddo
      enddo
!
      return
      end


! Set initial conditions for q.
subroutine qinit(meqn, mbc, mx, my, mz, xlower, ylower, zlower, dx, dy, dz, q, maux, aux)

    implicit none

    ! Input/Output
    integer, intent(in) :: meqn, mbc, mx, my, mz, maux
    real(kind=8), intent(in) :: xlower, ylower, zlower, dx, dy, dz
    real(kind=8), intent(inout) :: q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc, 1-mbc:mz+mbc)
    real(kind=8), intent(in) :: aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc, 1-mbc:mz+mbc)

    ! Local storage
    integer :: i, j, k
    real(kind=8) :: x, y, z, r, rho

    do i = 1, mx
        x = xlower + (i - 0.5d0) * dx
        do j = 1, my
            y = ylower + (j - 0.5d0) * dy
            do k = 1, mz
                z = zlower + (k - 0.5d0) * dz
                r = sqrt(x**2 + y**2 + z**2)
                rho = 1.d0 + 10.d0 * exp(-20.d0 * (r - 0.d0)**2)
                q(1, i, j, k) = rho
                q(2, i, j, k) = 0.d0
                q(3, i, j, k) = 0.d0
                q(4, i, j, k) = 0.d0
                q(5, i, j, k) = 0.d0
            end do
        end do
    end do
end subroutine qinit


subroutine eval_curve(s, t, k, coef, nctl, ndim, n, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_surf is a vector version of the B-spline evaluation function
  !
  !     Description of Arguments
  !     Input
  !     s       - Real, Vector of s coordinates, length n
  !     t       - Real, Knot vector. Length nctl+k
  !     k       - Integer, order of B-spline
  !     coef    - Real, Array of b-sline coefficients  Size (ndim, nctl)
  !     nctl    - Integer, Number of control points
  !
  !     Ouput
  !     val     - Real, Evaluated points, size ndim by n

  use precision
  implicit none
  ! Input
  integer         , intent(in)     :: k, nctl, ndim, n
  real(kind=realType), intent(in)  :: s(n)
  real(kind=realType), intent(in)  :: t(nctl+k)
  real(kind=realType), intent(in)  :: coef(ndim, nctl)

  ! Output
  real(kind=realType), intent(out) :: val(ndim, n)

  ! Working
  integer                          :: i, l, idim, istart, ileft
  real(kind=realType)              :: basisu(k)

  val(:, :) = 0.0
  do i=1, n
     call findSpan(s(i), k, t, nctl, ileft)
     call basis(t, nctl, k, s(i), ileft, basisu)
     istart = ileft-k
     do l=1, k
        do idim=1, ndim
           val(idim, i) = val(idim, i) + basisu(l)*coef(idim, istart+l)
        end do
     end do
  end do
end subroutine eval_curve

subroutine eval_curve_deriv(s, t, k, coef, nctl, ndim, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_surf_deriv is a scalar version of the
  !              B-spline derivative evaluation function
  !
  !     Description of Arguments
  !     Input
  !     s       - Real, s coordinate
  !     t       - Real, Knot vector. Length nctl+k
  !     k       - Integer, order of B-spline
  !     coef    - Real, Array of B-spline coefficients. Size (ndim, nctl)
  !     nctl   - Integer, Number of control points
  !
  !     Ouput
  !     val     - Real, Evaluated point, size ndim

  use precision
  implicit none

  ! Input
  integer         , intent(in)          :: k, nctl, ndim
  real(kind=realType), intent(in)       :: s
  real(kind=realType), intent(in)       :: t(nctl+k)
  real(kind=realType), intent(in)       :: coef(ndim, nctl)

  ! Output
  real(kind=realType), intent(out)      :: val(ndim)

  ! Working
  integer                               :: idim

  ! Functions
  real(kind=realType)                   :: bvalu

  do idim=1, ndim
     val(idim) = bvalu(t, coef(idim, :), nctl, k, 1, s)
  end do

end subroutine eval_curve_deriv

subroutine eval_curve_deriv2(s, t, k, coef, nctl, ndim, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_curve_deriv2 evals the 2nd derivative
  !              B-spline derivative evaluation function
  !
  !     Description of Arguments
  !     Input
  !     s       - Real, s coordinate
  !     t       - Real, Knot vector. Length nctl+k
  !     k       - Integer, order of B-spline
  !     coef    - Real, Array of B-spline coefficients Size (ndim, nctl)
  !     nctl    - Integer, Number of control points
  !
  !     Ouput
  !     val     - Real, Evaluated point, size ndim

  use precision
  implicit none
  ! Input
  integer         , intent(in)             :: k, nctl, ndim
  real(kind=realType), intent(in)          :: s
  real(kind=realType), intent(in)          :: t(nctl+k)
  real(kind=realType), intent(in)          :: coef(ndim, nctl)

  ! Output
  real(kind=realType), intent(out)         :: val(ndim)

  ! Working
  integer                                  :: idim

  ! Functions
  real(kind=realType)                      :: bvalu

  if (k == 2) then
     val(:) = 0.0
  else
     do idim=1, ndim
        val(idim) = bvalu(t, coef(idim, :), nctl, k, 2, s)
     end do
  end if

end subroutine eval_curve_deriv2

subroutine eval_curve_c(s, t, k, coef, nctl, ndim, n, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_curve_complex is a special version for evaluation
  !     of data when control points are used in a complex-step analysis
  !     The actual derivative is computed analytically, but the output looks
  !     like the CS went all the way through
  !
  !     Description of Arguments
  !     Input
  !     s       - Real, s coordinate
  !     t       - Real, Knot vector. Length nctl+k
  !     k       - Integer, order of B-spline
  !     coef    - Real, Array of B-spline coefficients  Size (ndim, nctl)
  !     nctl   - Integer, Number of control points
  !
  !     Ouput
  !     val     - Real, Evaluated point, size ndim

  use precision
  implicit none
  ! Input
  integer                , intent(in)   :: k, nctl, ndim, n
  complex(kind=realType) , intent(in)   :: s(n)
  real(kind=realType)    , intent(in)   :: t(nctl+k)
  complex(kind=realType) , intent(in)   :: coef(ndim, nctl)

  ! Output
  complex(kind=realType) , intent(out)  :: val(ndim, n)

  ! Working
  integer                               :: i, l, istart, ileft, idim
  complex(kind=realType)                   :: basisu(k)

  val(:, :) = cmplx(0.0, 0.0)
  do i=1, n
     call findSpan(real(s(i)), k, t, nctl, ileft)
     call basis_c(t, nctl, k, s(i), ileft, basisu)

     istart = ileft - k
     do l=1, k
        do idim=1, ndim
           val(idim, i) = val(idim, i) + basisu(l)*coef(idim, istart+l)
        end do
     end do
  end do
end subroutine eval_curve_c

subroutine eval_curve_deriv_c(s, t, k, coef, nctl, ndim, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_surf_deriv is a scalar version of the
  !              B-spline derivative evaluation function
  !
  !     Description of Arguments
  !     Input
  !     s       - Real, s coordinate
  !     t       - Real, Knot vector. Length nctl+k
  !     k       - Integer, order of B-spline
  !     coef    - Complex, Array of B-spline coefficients. Size (ndim, nctl)
  !     nctl    - Integer, Number of control points
  !
  !     Ouput
  !     val     - Complex, Evaluated derivative, size ndim

  use precision
  implicit none
  ! Input
  integer               , intent(in)          :: k, nctl, ndim
  real(kind=realType)   , intent(in)          :: s
  real(kind=realType)   , intent(in)          :: t(nctl+k)
  complex(kind=realType), intent(in)          :: coef(ndim, nctl)

  ! Output
  complex(kind=realType), intent(out)         :: val(ndim)

  ! Working
  integer                                     :: idim

  ! Functions
  complex(kind=realType)                      :: cbvalu

  do idim=1, ndim
     val(idim) = cbvalu(t, coef(idim, :), nctl, k, 1, s)
  end do

end subroutine eval_curve_deriv_c

subroutine eval_curve_deriv2_c(s, t, k, coef, nctl, ndim, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_curve_deriv2 evals the 2nd derivative
  !              B-spline derivative evaluation function
  !
  !     Description of Arguments
  !     Input
  !     s       - Real, s coordinate
  !     t       - Real, Knot vector. Length nctl+k
  !     k       - Integer, order of B-spline
  !     coef    - Complex, Array of B-spline coefficients Size (ndim, nctl)
  !     nctl    - Integer, Number of control points
  !
  !     Ouput
  !     val     - Real, Evaluated point, size ndim

  use precision
  implicit none
  ! Input
  integer               , intent(in)          :: k, nctl, ndim
  real(kind=realType)   , intent(in)          :: s
  real(kind=realType)   , intent(in)          :: t(nctl+k)
  complex(kind=realType), intent(in)          :: coef(ndim, nctl)

  ! Output
  complex(kind=realType), intent(out)         :: val(ndim)

  ! Working
  integer                                     :: idim

  ! Functions
  complex(kind=realType)                      :: cbvalu

  do idim=1, ndim
     val(idim) = cbvalu(t, coef(idim, :), nctl, k, 2, s)
  end do

end subroutine eval_curve_deriv2_c


subroutine itemwise_add_integer(input1, input2, output)
  implicit none
  integer, dimension(:), intent(in) :: input1
  integer, dimension(:), intent(in) :: input2
  integer, dimension(size(input1)), intent(out) :: output
  integer :: n

  do n = 1, size(input1)
    output(n) = input1(n) + input2(n)
  end do
  return
end subroutine

subroutine itemwise_add_real(input1, input2, output)
  implicit none
  real, dimension(:), intent(in) :: input1
  real, dimension(:), intent(in) :: input2
  real, dimension(size(input1)), intent(out) :: output
  integer :: n

  do n = 1, size(input1)
    output(n) = input1(n) + input2(n)
  end do
  return
end subroutine

subroutine itemwise_subtract_integer(input1, input2, output)
  implicit none
  integer, dimension(:), intent(in) :: input1
  integer, dimension(:), intent(in) :: input2
  integer, dimension(size(input1)), intent(out) :: output
  integer :: n

  do n = 1, size(input1)
    output(n) = input1(n) - input2(n)
  end do
  return
end subroutine

subroutine itemwise_subtract_real(input1, input2, output)
  implicit none
  real, dimension(:), intent(in) :: input1
  real, dimension(:), intent(in) :: input2
  real, dimension(size(input1)), intent(out) :: output
  integer :: n

  do n = 1, size(input1)
    output(n) = input1(n) - input2(n)
  end do
  return
end subroutine

subroutine itemwise_multiply_integer(input1, input2, output)
  implicit none
  integer, dimension(:), intent(in) :: input1
  integer, dimension(:), intent(in) :: input2
  integer, dimension(size(input1)), intent(out) :: output
  integer :: n

  do n = 1, size(input1)
    output(n) = input1(n) * input2(n)
  end do
  return
end subroutine

subroutine itemwise_multiply_real(input1, input2, output)
  implicit none
  real, dimension(:), intent(in) :: input1
  real, dimension(:), intent(in) :: input2
  real, dimension(size(input1)), intent(out) :: output
  integer :: n

  do n = 1, size(input1)
    output(n) = input1(n) * input2(n)
  end do
  return
end subroutine


module bessel_mod

contains

      SUBROUTINE BESIC (Z,N,B,IER)
!
! PACKAGE BESC           (NOTE---DOCUMENTATION FOR INDIVIDUAL ROUTINES
!                        FOLLOWS THE GENERAL PACKAGE INFORMATION.)
!
! LATEST REVISION        NOVEMBER 1978
!
! PURPOSE                TO CALCULATE BESSEL FUNCTIONS I AND J FOR
!                        COMPLEX ARGUMENT AND INTEGER ORDERS.
!
! USAGE                  TO CALCULATE I BESSEL FUNCTIONS---
!
!                          CALL BESIC(Z,N,B,IER)
!
!                        TO CALCULATE J BESSEL FUNCTIONS---
!
!                          CALL BESJC(Z,N,B,IER)
!
! ENTRY POINTS           BESIC,BESJC,B2SLCI
!
! COMMON BLOCKS          NONE
!
! I/O                    NONE, EXCEPT FOR ERROR MESSAGES PRODUCED BY
!                        CALLING THE ERROR HANDLING ROUTINE ULIBER.
!
! REQUIRED LIBRARY       NONE
! ROUTINES
!
! SPECIALIST             RUSSELL K. REW
!
! LANGUAGE               FORTRAN
!
! HISTORY                DAVID J. SOOKNE WROTE THE CORE ROUTINE B2SLCI,
!                        WHICH WAS ORIGINALLY DOUBLE PRECISION.  THE
!                        SINGLE PRECISION VERSION, AND THE USER ENTRIES
!                        BESIC AND BESJC WERE WRITTEN BY RUSSELL K. REW
!                        IN SEPTEMBER, 1977.
!
! SPACE REQUIRED         1712 (OCTAL) = 970 (DECIMAL) ON THE 7600.
!
! PORTABILITY            THIS PACKAGE CONFORMS TO THE 1966 ANSI STANDARD
!                        AS CONFIRMED BY THE PFORT VERIFIER.  THERE ARE
!                        FOUR MACHINE DEPENDENT CONSTANTS IN B2SLCI THAT
!                        ARE DESCRIBED IN COMMENT CARDS.
!
! REQUIRED RESIDENT      ULIBER (AN ERROR ROUTINE),SQRT,EXP,COS,SIN
! ROUTINES
!
! REFERENCES             "BESSEL FUNCTIONS I AND J OF COMPLEX
!                        ARGUMENT AND INTEGER ORDER" AND
!                        "CERTIFICATION OF AN ALGORITHM FOR
!                        BESSEL FUNCTIONS OF COMPLEX ARGUMENT"
!                        BOTH BY DAVID J. SOOKNE, JOURNAL OF REASEARCH
!                        OF THE NATIONAL BUREAU OF STANDARDS-B. MATHE-
!                        MATICAL SCIENCES, VOL. 77A, NOS. 3 AND 4, JULY-
!                        DECEMBER, 1973.
!
! METHOD                 BACKWARD RECURSION WITH STRICT CONTROL OF
!                        ERROR.
!
!-----------------------------------------------------------------------
!
! SUBROUTINE BESIC (Z,N,B,IER)
!
! DIMENSION OF           B(N+1)
! ARGUMENTS
!
! LATEST REVISION        OCTOBER 1978
!
! PURPOSE                TO CALCULATE I BESSEL FUNCTIONS FOR COMPLEX
!                        ARGUMENT AND INTEGER ORDER
!
! USAGE                  CALL BESIC (Z,N,B,IER)
!
! ARGUMENTS
!
! ON INPUT               Z
!                          COMPLEX ARGUMENT FOR WHICH I BESSEL FUNCTIONS
!                          ARE TO BE CALCULATED.  ABS(AIMAG(Z)) MUST BE
!                          LESS THAN THE LARGEST REAL ARGUMENT THAT THE
!                          FORTRAN FUNCTION EXP CAN HANDLE.
!
!                        N
!                          INTEGER, THE HIGHEST ORDER TO BE CALCULATED.
!                          N MUST BE GREATER THAN OR EQUAL TO ZERO.
!
! ON OUTPUT              B
!                          COMPLEX VECTOR OF LENGTH N+1 CONTAINING THE
!                          BESSEL FUNCTION VALUES I-SUB-0(Z),I-SUB-1(Z),
!                          ...,I-SUB-N(Z) IN B(1),B(2),...,B(N+1).
!                        IER
!                          AN INTEGER ERROR FLAG.
!                          =0 IF ALL DESIRED ORDERS HAVE BEEN CALCULATED
!                             SATISFACTORILY,
!                          =1 IF ABS(AIMAG(Z)) IS TOO LARGE,
!                          =2 IF N IS LESS THAN ZERO,
!                          =2+K IF ONLY THE FIRST K RESULTS ARE CORRECT.
!                             IN THE RETURNED VALUES B(M) FOR M GREATER
!                             THAN K, APPROXIMATELY THE LAST
!                             ALOG10(ABS(B(M)/B(K))) SIGNIFICANT DIGITS
!                             ARE IN ERROR.
!
! ENTRY POINTS           BESIC
!
! SPECIAL CONDITIONS     NONE
!
! COMMON BLOCKS          NONE
!
! I/O                    NONE, EXCEPT FOR ERROR MESSAGES PRODUCED BY
!                        CALLING THE ERROR HANDLING ROUTINE ULIBER.
!
! PRECISION              SINGLE
!
! SPECIALIST             RUSS REW, NCAR, BOULDER, COLORADO
!
! ACCURACY               IN TESTS RUN ON THE 7600 WITH ORDERS FROM 0
!                        THROUGH 10 USING RANDOM VALUES OF THE ARGUMENT
!                        WITH ABSOLUTE VALUE LESS THAN 50 BUT
!                        CONCENTRATED AROUND THE ORIGIN, THE MAXIMUM
!                        RELATIVE ERROR (OR ABSOLUTE ERROR WHEN IT WAS
!                        LARGER) OBSERVED WAS ABOUT 8.1E-14.
!
! TIMING                 ON NCAR"S CONTROL DATA 7600, BESIC TAKES ABOUT
!                        .32+.008*N MILLISECONDS WHEN Z=(1.0,1.0).
!
! PORTABILITY            ANSI 1966 STANDARD
!
!
!
!
!
!
      COMPLEX         Z          ,B(100)
      real b2(2, 100)

      DATA IORJ/1/,XLARGE/741.66/

      NB = N+1

      CALL B2SLCI (REAL(Z),AIMAG(Z),NB,IORJ,B2,NCALC)

      do n = 1, nb
         b(n) = cmplx(b2(1,n), b2(2,n))
      end do

      IER = 0
      IF (NCALC .EQ. NB) GO TO 103
      IF (NCALC .GE. 0) GO TO 102
      IF (N .GE. 0) GO TO 101
      IER = 2
      CALL ULIBER (IER,'IN BESIC, N OUT OF RANGE')
      GO TO 103
  101 IER = 1
      CALL ULIBER (IER,'IN BESIC, X OUT OF RANGE')
      GO TO 103
  102 IER = 2+NCALC
      CALL ULIBER (IER,'IN BESIC, ACCURACY LOST FOR SOME ORDERS')
  103 RETURN
      END SUBROUTINE BESIC

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

      subroutine b2slci (x,y,nb,ize,b,ncalc)
!
! this routine calculates bessel functions i and j of
! complex argument and integer order.
!
!
!      explanation of variables in the calling sequence
!
! x     real part of the complex argument
!       for which i*s or j*s are to be calculated.  if i*s
!       are to be calculated, abs(x) must not exceed exparg
!       (which see below).
! y     imaginary part of the argument.  if j*s are to be
!       calculated, abs(y) must not exceed exparg.
! nb    integer type.  1 + highest order to be calculated.
!       it must be positive.
! ize   integer type.  zero if j*s are to be calculated, 1
!       if i*s are to be calculated.
! b     real array dimensioned b(2,nb), need not be initialized by user.
!       if the routine terminates normally, (ncalc=nb), it returns
!       j(or i)-sub-zero through j(or i)-sub-nb-minus-one of z in b.
!       the real parts of the results are returned in b(1,n) and the
!       corresponding imaginary parts are returned in b(2,n) for n=1,2,
!       ...,nb.  (in the documentation below, br(n) and bi(n) refer to
!       b(1,n) and b(2,n), respectively.)
! ncalc integer type, need not be initialized by user.
!       before using the results, the user should check that
!       ncalc=nb, i.e. all orders have been calculated to
!       the desired accuracy.  see error returns below.
!
!
!       explanation of machine-dependent constants
!
! nsig  decimal significance desired.  should be set to
!       int(alog10(2)*nbit+1), where nbit is the number of
!       bits in the mantissa of a real variable.
!       setting nsig higher will increase cpu time without
!       increasing accuracy, while setting nsig lower will
!       decrease accuracy.  if only single-precision
!       accuracy is desired, replace nbit by the number of
!       bits in the mantissa of a single-precision variable.
!       the relative truncation error is limited to t=.5*10
!       **-nsig for order greater than abs(z), and for order
!       less than abs(z) (general test), the relative error
!       is limited to t for function values of magnitude at
!       least 1, and the absolute error is limited to t for
!       smaller values.
! nten  largest integer k such that 10**k is machine-
!       representable in real.
! largez upper limit on the magnitude of z.  bear in mind
!       that if abs(z)=n, then at least n iterations of the
!       backward recursion will be executed.
! exparg largest real argument that the library
!       exp routine can handle.
!
!
!                            error returns
!
!       let g denote either i or j.
!       in case of an error, ncalc.ne.nb, and not all g*s
!  are calculated to the desired accuracy.
!       if ncalc.lt.0, an argument is out of range.  nb.le.0
!  or ize is neither 0 nor 1 or ize=0 and abs(y).gt.exparg,
!  or ize=1 and abs(x).gt.exparg.  in this case, the vectors
!  br and bi are not calculated, and ncalc is set to
!  min0(nb,0)-1 so ncalc.ne.nb.
!       nb.gt.ncalc.gt.0 will occur if nb.gt.magz and abs(g-
!  sub-nb-of-z/g-sub-magx+np-of-z).lt.10.**(nten/2), i.e. nb
!  is much greater than magz.  in this case, br(n) and bi(n)
!  are calculated to the desired accuracy for n.le.ncalc,
!  but for ncalc.lt.n.le.nb, precision is lost.  if n.gt.
!  ncalc and abs(g(ncalc-1)/g(n-1)).eq.10**-k, then the last
!  k significant figures of g(n-1) (=br(n)+i*bi(n)) are
!  erroneous.  if the user wishes to calculate g(n-1) to
!  higher accuracy, he should use an asymptotic formula for
!  large order.
!
      real            x          ,y          ,b          ,pr         , &
                      pi         ,plastr     ,plasti     ,poldr      , &
                      poldi      ,psaver     ,psavei     ,exparg     , &
                      test       ,tover      ,tempar     ,tempai     , &
                      tempbr     ,tempbi     ,tempcr     ,tempci     , &
                      sign       ,sumr       ,sumi       ,zinvr      , &
                      zinvi
      dimension       b(2,nb)
!
! machine dependent data for 7600 and cray
!
!      data nsig,nten,largez,exparg
!     1    /15,293,100000,741.66e0/
!     data nsig/15/,nten/293/,largez/100000/,exparg/741.66/

! MACHINE DEPENDENT DATA FOR VAX
!
!     DATA NSIG,NTEN,LARGEZ,EXPARG
!    1    /7,38,10000.,88.02/

!
! machine dependent data for IBM 580 workstation
!
!     data nsig/15/,nten/308/,largez/100000/,exparg/709.78/
      data nsig/15/,nten/308/,largez/100000/,exparg/709.78/

      tempar = sqrt(x*x+y*y)
      magz = int((tempar))
      if (nb.gt.0 .and. magz.le.largez .and. &
          ((ize.eq.0 .and. abs(y).le.exparg) .or. &
                                     (ize.eq.1 .and. abs(x).le.exparg))) &
          go to 101
!
! error return -- z, nb, or ize is out of range
!
      ncalc = min0(nb,0)-1
      return
  101 sign = (float(1-2*ize))
      ncalc = nb
!
! use 2-term ascending series for small z
!
      if (tempar**4 .lt. .1e0**nsig) go to 136
!
! initialize the calculation of the p*s
!
      nbmz = nb-magz
      n = magz+1
      if (abs(x) .lt. abs(y)) go to 102
      zinvr = 1.e0/(x+y*y/x)
      zinvi = -y*zinvr/x
      go to 103
  102 zinvi = -1.e0/(y+x*x/y)
      zinvr = -x*zinvi/y
  103 plastr = 1.e0
      plasti = 0.e0
      pr = sign*(float(2*n))*zinvr
      pi = sign*(float(2*n))*zinvi
      test = 2.e0*1.e1**nsig
      m = 0
      if (nbmz .lt. 3) go to 105
!
! calculate p*s until n=nb-1.  check for possible overflow.
!
! the following devious computation replaces
!     tover=10.0**(nten-nsig)
! and is necessitated by the poor power algorithm on the ncar 7600
! in order to prevent overflow
!
      intemp = nten-nsig
      inhlf = intemp/2
      tover = 10.0**inhlf*10.0**(intemp-inhlf)
      nstart = magz+2
      nend = nb-1
      do 104 n=nstart,nend
         poldr = plastr
         poldi = plasti
         plastr = pr
         plasti = pi
         pr = sign*((float(2*n))*(plastr*zinvr-plasti*zinvi)-poldr)
         pi = sign*((float(2*n))*(plasti*zinvr+plastr*zinvi)-poldi)
         if ((pr/tover)**2+(pi/tover)**2-1.e0) 104,104,106
  104 continue
      n = nend
!
! calculate special significance test for nbmz.gt.2.
!
      tempbi = max(abs(pr),abs(pi))
      tempbi = tempbi*sqrt(2.e0*1.e1**nsig* &
               sqrt(((pr/tempbi)**2+(pi/tempbi)**2)* &
                               ((plastr/tempbi)**2+(plasti/tempbi)**2)))
      test = max(test,tempbi)
!
! calculate p*s until significance test is passed.
!
  105 n = n+1
      poldr = plastr
      poldi = plasti
      plastr = pr
      plasti = pi
      pr = sign*((float(2*n))*(plastr*zinvr-plasti*zinvi)-poldr)
      pi = sign*((float(2*n))*(plasti*zinvr+plastr*zinvi)-poldi)
      if ((pr/test)**2+(pi/test)**2 .lt. 1.e0) go to 105
      if (m .eq. 1) go to 110
!
! calculate strict variant of significance test, and
! calculate p*s until this test is passed.
!
      m = 1
      tempbi = max(abs(pr),abs(pi))
      tempbr = sqrt(((pr/tempbi)**2+(pi/tempbi)**2)/ &
                                ((plastr/tempbi)**2+(plasti/tempbi)**2))
      tempbi = (float(n+1))/tempar
      if (tempbr+1.e0/tempbr .gt. 2.e0*tempbi) &
          tempbr = tempbi+sqrt(tempbi**2-1.e0)
      test = test/sqrt(tempbr-1.e0/tempbr)
      if ((pr/test)**2+(pi/test)**2-1.e0) 105,110,110
  106 nstart = n+1
!
! to avoid overflow, normalize p*s by dividing by tover.
! calculate p*s until unnormalized p would overflow.
!
      pr = pr/tover
      pi = pi/tover
      plastr = plastr/tover
      plasti = plasti/tover
      psaver = pr
      psavei = pi
      tempcr = plastr
      tempci = plasti
      test = 1.e1**(2*nsig)
  107 n = n+1
      poldr = plastr
      poldi = plasti
      plastr = pr
      plasti = pi
      pr = sign*((float(2*n))*(plastr*zinvr-plasti*zinvi)-poldr)
      pi = sign*((float(2*n))*(plasti*zinvr+plastr*zinvi)-poldi)
      if (pr**2+pi**2 .le. test) go to 107
!
! calculate backward test, and find ncalc, the highest n
! such that the test is passed.
!
      tempbr = sqrt((plastr**2+plasti**2)/(poldr**2+poldi**2))
      tempbi = (float(n))/tempar
      if (tempbr+1.e0/tempbr .gt. 2.e0*tempbi) &
          tempbr = tempbi+sqrt(tempbi**2-1.e0)
      test = .5e0*(1.e0-1.e0/tempbr**2)/1.e1**nsig
      test = ((plastr**2+plasti**2)*test)*((poldr**2+poldi**2)*test)
      pr = plastr*tover
      pi = plasti*tover
      n = n-1
      nend = min0(nb,n)
      do 108 ncalc=nstart,nend
         poldr = tempcr
         poldi = tempci
         tempcr = psaver
         tempci = psavei
         psaver = sign*((float(2*n))*(tempcr*zinvr-tempci*zinvi)-poldr)
         psavei = sign*((float(2*n))*(tempci*zinvr+tempcr*zinvi)-poldi)
         if ((psaver**2+psavei**2)*(tempcr**2+tempci**2)-test) &
             108,108,109
  108 continue
      ncalc = nend+1
  109 ncalc = ncalc-1
!
! the coefficient of b(n) in the normalization sum is
! m*sqrt(-1)**imag, where m=-2,0, or 2, and imag is 0 or 1.
! calculate recursion rules for m and imag, and initialize
! them.
!
  110 n = n+1
      tempbr = (float(ize))*x+(float(1-ize))*y
      ipos = 0
      if (tempbr) 111,112,111
  111 ipos = int((1.1e0*tempbr/abs(tempbr)))
  112 mrecur = 4*((2+ize+ipos)/2)-3-2*(ize+ipos)
      k = 2+ipos+2*ize*ipos**2-ize
      l = n-4*(n/4)
      mlast = 2+8*((k*l)/4)-4*((k*l)/2)
      if (ipos.eq.0 .and. (l.eq.1 .or. l.eq.3)) mlast = 0
      l = l+3-4*((l+3)/4)
      m = 2+8*((k*l)/4)-4*((k*l)/2)
      if (ipos.eq.0 .and. (l.eq.1 .or. l.eq.3)) m = 0
      imrecr = (1-ize)*ipos**2
      imag = imrecr*(l-2*(l/2))
!
! initialize the backward recursion and the normalization
! sum.
!
      tempbr = 0.e0
      tempbi = 0.e0
      if (abs(pi) .gt. abs(pr)) go to 113
      tempar = 1.e0/(pr+pi*(pi/pr))
      tempai = -(pi*tempar)/pr
      go to 114
  113 tempai = -1.e0/(pi+pr*(pr/pi))
      tempar = -(pr*tempai)/pi
  114 if (imag .ne. 0) go to 115
      sumr = (float(m))*tempar
      sumi = (float(m))*tempai
      go to 116
  115 sumr = -(float(m))*tempai
      sumi = (float(m))*tempar
  116 nend = n-nb
      if (nend) 123,120,117
!
! recur backward via difference equation calculating (but
! not storing) br(n) and bi(n) until n=nb.
!
  117 do 119 l=1,nend
         n = n-1
         tempcr = tempbr
         tempci = tempbi
         tempbr = tempar
         tempbi = tempai
         pr = (float(2*n))*zinvr
         pi = (float(2*n))*zinvi
         tempar = pr*tempbr-pi*tempbi-sign*tempcr
         tempai = pr*tempbi+pi*tempbr-sign*tempci
         imag = (1-imag)*imrecr
         k = mlast
         mlast = m
         m = k*mrecur
         if (imag .ne. 0) go to 118
         sumr = sumr+(float(m))*tempar
         sumi = sumi+(float(m))*tempai
         go to 119
  118    sumr = sumr-(float(m))*tempai
         sumi = sumi+(float(m))*tempar
  119 continue
!
! store br(nb), bi(nb)
!
  120 b(1,n) = tempar
      b(2,n) = tempai
      if (n .gt. 1) go to 121
!
! nb=1.  since 2*tempar and 2*tempai were added to sumr and
! sumi respectively, we must subtract tempar and tempai
!
      sumr = sumr-tempar
      sumi = sumi-tempai
      go to 130
!
! calculate and store br(nb-1),bi(nb-1)
!
  121 n = n-1
      pr = (float(2*n))*zinvr
      pi = (float(2*n))*zinvi
      b(1,n) = pr*tempar-pi*tempai-sign*tempbr
      b(2,n) = pr*tempai+pi*tempar-sign*tempbi
      if (n .eq. 1) go to 129
      imag = (1-imag)*imrecr
      k = mlast
      mlast = m
      m = k*mrecur
      if (imag .ne. 0) go to 122
      sumr = sumr+(float(m))*b(1,n)
      sumi = sumi+(float(m))*b(2,n)
      go to 125
  122 sumr = sumr-(float(m))*b(2,n)
      sumi = sumi+(float(m))*b(1,n)
      go to 125
!
! n.lt.nb, so store br(n), bi(n), and set higher orders zero
!
  123 b(1,n) = tempar
      b(2,n) = tempai
      nend = -nend
      do 124 l=1,nend
         b(1,n+l) = 0.e0
         b(2,n+l) = 0.e0
  124 continue
  125 nend = n-2
      if (nend .eq. 0) go to 128
!
! calculate via difference equation and store br(n),bi(n),
! until n=2
!
      do 127 l=1,nend
         n = n-1
         pr = (float(2*n))*zinvr
         pi = (float(2*n))*zinvi
         b(1,n) = pr*b(1,n+1)-pi*b(2,n+1)-sign*b(1,n+2)
         b(2,n) = pr*b(2,n+1)+pi*b(1,n+1)-sign*b(2,n+2)
         imag = (1-imag)*imrecr
         k = mlast
         mlast = m
         m = k*mrecur
         if (imag .ne. 0) go to 126
         sumr = sumr+(float(m))*b(1,n)
         sumi = sumi+(float(m))*b(2,n)
         go to 127
  126    sumr = sumr-(float(m))*b(2,n)
         sumi = sumi+(float(m))*b(1,n)
  127 continue
!
! calculate and store br(1), bi(1)
!
  128 b(1,1) = 2.e0*(b(1,2)*zinvr-b(2,2)*zinvi)-sign*b(1,3)
      b(2,1) = 2.e0*(b(1,2)*zinvi+b(2,2)*zinvr)-sign*b(2,3)
  129 sumr = sumr+b(1,1)
      sumi = sumi+b(2,1)
!
! calculate normalization factor, tempar +i*tempai
!
  130 if (ize .eq. 1) go to 131
      tempcr = (float(ipos))*y
      tempci = (float(-ipos))*x
      go to 132
  131 tempcr = (float(ipos))*x
      tempci = (float(ipos))*y
  132 tempcr = exp(tempcr)
      tempbr = cos(tempci)
      tempbi = sin(tempci)
      if (abs(sumr) .lt. abs(sumi)) go to 133
      tempci = sumi/sumr
      tempcr = (tempcr/sumr)/(1.e0+tempci*tempci)
      tempar = tempcr*(tempbr+tempbi*tempci)
      tempai = tempcr*(tempbi-tempbr*tempci)
      go to 134
  133 tempci = sumr/sumi
      tempcr = (tempcr/sumi)/(1.e0+tempci*tempci)
      tempar = tempcr*(tempbr*tempci+tempbi)
      tempai = tempcr*(tempbi*tempci-tempbr)
!
! normalize
!
  134 do 135 n=1,nb
         tempbr = b(1,n)*tempar-b(2,n)*tempai
         b(2,n) = b(1,n)*tempai+b(2,n)*tempar
         b(1,n) = tempbr
  135 continue
      return
!
! two-term ascending series for small z
!
  136 tempar = 1.e0
      tempai = 0.e0
      tempcr = .25e0*(x*x-y*y)
      tempci = .5e0*x*y
      b(1,1) = 1.e0-sign*tempcr
      b(2,1) = -sign*tempci
      if (nb .eq. 1) go to 138
      do 137 n=2,nb
         tempbr = (tempar*x-tempai*y)/(float(2*n-2))
         tempai = (tempar*y+tempai*x)/(float(2*n-2))
         tempar = tempbr
         tempbr = (float(n))
         b(1,n) = tempar*(1.e0-sign*tempcr/tempbr)+tempai*tempci/tempbr
         b(2,n) = tempai*(1.e0-sign*tempcr/tempbr)-tempar*tempci/tempbr
  137 continue
  138 return
!
! revision history---
!
! october 1978     first added to nssl
! november 1978    changed the value of the machine dependent constant
!                  nten from 322 to 293 to correct an undetected
!                  underflow and subsequent division of 0 by 0 when
!                  besir was called with large n (greater than 140).
!-----------------------------------------------------------------------
      end subroutine b2slci
!
! uliber     from portlib                                  12/27/80
      subroutine uliber (ierr,messg)
!
! dimension of           messg(1+(nmessg-1)/ncpwd), where ncpwd is the
! arguments              number of characters that can be stored in one
!                        integer word.
!
! latest revision        april 1977.
!
! purpose                prints an error message.
!
! usage                  call uliber (ierr,messg,nmessg)
!
! arguments
!
! on input               ierr
!                          error number.  if ierr .lt. 32, the error is
!                          considered to be non-fatal and uliber returns
!                          after printing the error message.  if ierr
!                          .ge. 32 the error is considered fatal, and
!                          uliber stops after printing the message.
!                        messg
!                          the error message to be printed.
!                        nmessg
!                          the length of the message, in characters.
!
    character(len=*), intent(in) :: messg
    integer, intent(in) :: ierr
!
! erunit should be set to the local unit number for error messages.
!
!
!      if (erunit .eq. 0) write(prunit,1000)
!
! 1000 format(50h1uliber, a subroutine to print error messages, has/
!     1       50h been called, but no local implementation of      /
!     2       50h uliber has been provided.  to properly implement /
!     3       50h this subroutine for the local machine and        /
!     4       50h environment, please see the comments in uliber.  /)
!
! replace the if statement and format statement above with the following
! code where $ncpwd should be replaced with the number of characters
! that can be stored in one integer word, and $n should be replaced by
! the value of 1+(79/$ncpwd).
!
       write(*,*) ierr,messg
!
   10 if (ierr .ge. 32) stop
      return
      end subroutine uliber
!
!**********************************************************************
!

      subroutine besir (x, nmax, b, ier)

      implicit none

      real x, b(100)
      integer n, ier, nmax

!     -------------------------------------------------
!     Calculates I Bessel functions for real argument x
!     and integer orders 0 to nmax - 1 [stored in b(1)
!     to b(nmax)] using "Numerical Recipes" routines
!     -------------------------------------------------

      b(1) = bessi0(x)
      b(2) = bessi1(x)
      if(nmax .le. 2) return

      do n = 2, nmax - 1
         b(n+1) = bessi(n,x)
      end do

      return
      end subroutine besir

!
!**********************************************************************
!
      function bessi(n,x)

      implicit none

      integer n, iacc
      real bessi, x, bigno, bigni
      parameter (iacc = 40, bigno = 1.0e10, bigni = 1.0e-10)
!     Uses bessi0
!     Returns the modified Bessel function In(x) for any real x and n.ge.2
      integer j, m
      real bi, bim, bip, tox
      if (n .lt. 2) then
              write(*,*) 'bad argument n in bessi'
              stop
      endif
      if (x .eq. 0.) then
         bessi = 0.
      else
         tox = 2.0/abs(x)
         bip = 0.0
         bi = 1.0
         bessi = 0.
         m = 2 * ((n + int(sqrt(float(iacc * n)))))
         do j = m, 1, -1
            bim = bip + float(j) * tox * bi
            bip = bi
            bi = bim
            if (abs(bi) .gt. bigno) then
               bessi = bessi * bigni
               bi = bi * bigni
               bip = bip * bigni
            endif
            if (j .eq. n) bessi = bip
         enddo
         bessi = bessi * bessi0(x) / bi
         if(x .lt. 0. .and. mod(n,2) .eq. 1) bessi = -bessi
      endif
      return
      end function bessi
!
!**********************************************************************
!
      function bessi0(x)

      implicit none

      real bessi0, x
!      Returns the modified Bessel function I0(x) for any real x
      real ax
      double precision p1, p2, p3, p4, p5, p6, p7, &
                       q1, q2, q3, q4, q5, q6, q7, q8, q9, y
      save  p1, p2, p3, p4, p5, p6, p7, &
            q1, q2, q3, q4, q5, q6, q7, q8, q9

      data p1, p2, p3, p4, p5, p6, p7 / 1.0d0, 3.5156229d0, 3.0899424d0, &
         1.2067492d0, 0.2659732d0, 0.360768d-1, 0.45813d-2 /

      data q1, q2, q3, q4, q5, q6, q7, q8, q9/0.39894228d0,0.1328592d-1, &
         0.225319d-2,-0.157565d-2, 0.916281d-2, -0.2057706d-1, &
         0.2635537d-1, -0.1647633d-1, 0.392377d-2 /

      if (abs(x) .lt. 3.75) then
         y = (x / 3.75)**2
         bessi0 = p1 + y * (p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7)))))
      else
         ax = abs(x)
         y = 3.75 / ax
         bessi0 = (exp(ax) / sqrt(ax)) * (q1+y*(q2+y*(q3+y*(q4 &
            +y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
      endif
      return
      end function bessi0
!
!**********************************************************************
!
      function bessi1(x)

      implicit none

      real bessi1, x
!      Returns the modified Bessel function I1(x) for any real x
      real ax
      double precision p1, p2, p3, p4, p5, p6, p7, &
                       q1, q2, q3, q4, q5, q6, q7, q8, q9, y
      save  p1, p2, p3, p4, p5, p6, p7, &
            q1, q2, q3, q4, q5, q6, q7, q8, q9

      data p1, p2, p3, p4, p5, p6, p7 / 0.5d0,0.87890594d0,0.51498869d0, &
         0.15084934d0, 0.2658733d-1, 0.301532d-2, 0.32411d-3 /

      data q1, q2, q3, q4, q5, q6, q7, q8, q9/0.39894228d0,-0.398802d-1, &
         -0.362018d-2,0.163801d-2,-0.1031555d-1, 0.2282967d-1, &
         -0.2895312d-1, 0.1787654d-1, -0.420059d-2 /

      if (abs(x) .lt. 3.75) then
         y = (x / 3.75)**2
         bessi1 = x * (p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
      else
         ax = abs(x)
         y = 3.75 / ax
         bessi1 = (exp(ax) / sqrt(ax)) * (q1+y*(q2+y*(q3+y*(q4 &
            +y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
      endif
      return
      end function bessi1

!
!**********************************************************************
!
      function factrl(n)
      integer n
      real factrl
!------------------------------------------------------
!     uses gammln
!     returns the value of n! as a floating point number
!-------------------------------------------------------

      integer j, ntop
      real a(33)
      save ntop, a
      data ntop, a(1)/0, 1./
      if(n .lt. 0) then
         write(*,*) 'negative factorial in factrl'
         stop
      else if (n .le. ntop)then
         factrl = a(n+1)
      else if (n .le. 32) then
         do j = ntop+1, n
            a(j+1) = j * a(j)
         end do
         ntop = n
         factrl = a(n+1)
      else
         factrl = exp(gammln(n+1.))
      end if

      return
      end function factrl

!
!*****************************************************************
!
      function gammln(xx)
      real gammln, xx
!         Returns the value ln(gamma(xx)) for xx > 0.
      integer j
      double precision ser, stp, tmp, x, y, cof(6)
!     internal arithmetic will be done in double precision,
!     a nicety that you can omit if five figure accuracy is good enough
      save cof, stp
      data cof, stp/76.18009172947146d0,-86.50532032941677d0, &
         24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, &
         -.5395239384953d-5,2.5066282746310005d0/
      x = xx
      y = x
      tmp = x + 5.5d0
      tmp = (x + 0.5d0) * log(tmp) - tmp
      ser=1.000000000190015d0
      do j = 1, 6
         y = y + 1.d0
         ser = ser + cof(j) / y
      end do
      gammln = tmp + log(stp * ser / x)
      return
      end function gammln

    subroutine besIExp &
        ( gamma_, lMax, expBes, expBesPrime, expBesOverGam )

        use constants

        ! Calculates exp(-gamma) times the modified bessel functions
        ! (and derivatives) of order up to lMax
        ! ----------------------------------------------------------

        implicit none

        integer, intent(in) :: lMax
        integer :: nmax, ier, l
        complex, intent(in) :: gamma_
        complex, intent(out) :: expBes(:), expBesPrime(:), expBesovergam(:)

        complex(kind=dbl), allocatable, dimension(:) :: besselI, besselIPrime, b
        complex(kind=dbl) :: expGam
        integer :: status
        complex(kind=dbl) :: gamma_dbl

        gamma_dbl = gamma_
        !LAB  added to lenght of arrays 1 and 3 to allow for lmax = 0
        allocate ( besselI(0:lMax+1), besselIPrime(0:lMax), b(lMax+2), stat = status )

        b       = 0
        besselI     = 0
        besselIPrime    = 0

        expGam = exp(-gamma_dbl)

        if ( cabs ( gamma_ ) <= 700.) then

           nmax = lmax
           call besic ( gamma_dbl, nmax, b, ier)

           if (ier/=0) then
                write(*,*) 'bessel.f90: ERROR - ', ier
           endif

           do l = 0, lMax + 1  !  LAB -- need to fix lMax = 0
              besselI(l) = b(l+1)
           enddo

           do l = 0, lmax

             if(l == 0) besselIPrime(0) = besselI(1)
             if(l /= 0) besselIPrime(l) = besselI(l-1) - l / gamma_dbl * besselI(l)
             expBes(l+1) = expGam * besselI(l)
             expBesPrime(l+1) = expGam * besselIPrime(l)

           enddo

        else

           do l = 0, lmax
              call bes_asym ( gamma_, l, expBes(l+1), expBesPrime(l+1) )
           enddo

        endif

        do l = 0, lmax
           expBesOverGam(l+1) = expBes(l+1) / gamma_
        enddo

        deallocate ( b )
        deallocate ( besselI )
        deallocate ( besselIPrime )

    end subroutine besIExp

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

    subroutine bes_expand &
        ( gamma_, lMax, expBes, expBesPrime, expBesOverGam)

        ! Calculates exp(-gamma) times the modified bessel functions
        ! (and derivatives) of order up to lmax using second order
        ! expansion for small argument
        ! -----------------------------------------------------------

        implicit none

        integer, intent(in) :: lMax
        complex, intent(in) :: gamma_
        complex, intent(inout) :: &
            expBes(0:lMax), &
            expBesPrime(0:lMax), &
            expBesOverGam(0:lMax)

        integer :: l
        real :: factl
        complex :: IlOverGam, exGam
        complex :: Il, IlPrime

        exGam = 1d0 - gamma_ + gamma_**2 / 2d0

        do l = 0, lmax

            factl = factrl(l)
            Il = gamma_**l / (2**l * factl) * &
                                          ( 1d0 + gamma_**2 / (4d0 * (l+1)))
            IlPrime = gamma_**(l-1) / (2**l * factl) * &
                              (l + (l+2) * gamma_**2 / (4d0 * (l+1)))

            IlOverGam = gamma_**(l-1) / (2**l * factl) * &
                                          ( 1d0 + gamma_**2 / (4d0 * (l+1)))

            expbes(l) = exGam * Il
            expBesPrime(l) = exGam * IlPrime
            expBesOverGam(l) = exGam * IlOverGam

        enddo

        return

    end subroutine bes_expand

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

      subroutine bes_asym ( z, n, exil, exilp )

        use constants

        implicit none

        integer :: mu, n
        complex z, exil, exilp

        mu = 4 * n**2
        exil =  1d0 / sqrt(2d0 * pi * z) &
           * (1d0 &
           - (mu - 1)/(8d0 * z) &
           + (mu - 1) * (mu - 9) / (2d0 * (8d0 * z)**2) &
           - (mu - 1) * (mu - 9) * (mu - 25) / (6d0 * (8d0 * z)**3)  )
        exilp = 1d0 / sqrt(2.0 * pi * z) &
           * (1d0 &
           - (mu + 3)/(8d0 * z) &
           + (mu - 1) * (mu + 15) / (2d0 * (8d0 * z)**2) &
           - (mu - 1) * (mu - 9) * (mu + 35) / (6d0 * (8d0 * z)**3)  )

        return

      end subroutine bes_asym

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

      function fzeta (arg)
      complex a1, a2, a3, b1, b2, b3, c1, c2, c3, d1, d2, d3, arg, aux0 &
         , aux1, term, z, zz, fzeta
      data d1r/0.0/
      data d1i/1.77245385090551/
      data d2r/0.0/
      data d2i/3.54490770181103/
      data d3r/0.0/
      data d3i/7.08981540362206/
      data d4/0.33333333333333/
      data eps/1.0E-07/

!     data d4/0.33333333333333/

!ray  code analysis
!ray  optimize
!
      i = 0
      z = arg
      zz = z*z
      x = real(z)
      y = aimag(z)
      d1 = cmplx(d1r,d1i)
      d2 = cmplx(d2r,d2i)
      d3 = cmplx(d3r,d3i)
      ymag = abs(y)
      if (ymag - 1.0 .ge. 0.) then
!
!     continued fraction method: abs(y).ge.1.0
!
         y0 = y
         y = ymag
         aux1 = 1.5 - z*z
         aux2 = 0.0
         del = 1.5
         a1 = 0.0
         a2 = -1.0
         b1 = 1.0
         b2 = aux1
         c1 = a2/b2
!
  100    continue
         aux1 = aux1 + 2.0
         aux2 = aux2 - del
         del = del + 2.0
         a3 = aux1*a2 + aux2*a1
         b3 = aux1*b2 + aux2*b1
         c2 = a3/b3
         c3 = c2 - c1
         c3r = real(c3)
         c3i = aimag(c3)
         if (abs(c3r) + abs(c3i) .lt. eps) go to 110
         a1 = a2
         a2 = a3
         b1 = b2
         b2 = b3
         c1 = c2
         go to 100
  110    continue
         if (y0 .lt. 0.) then
            y = y0
            c2 = conjg(c2) - d3*z*exp(-zz)
         endif
         aux0 = -(0.5*c2 + 1.0)/z
      else
!
!     asymptotic series method: abs(x).ge.4.0 and abs(y).lt.1.0
!
         xmag = abs(x)
         if (xmag - 4.0 .lt. 0.) go to 130
         term = 1.0/z
         aux0 = -term
         aux1 = 0.5*term**2
         p = 1.0
         if (y .le. 0.) then
            if (y .ne. 0.) then
               aux0 = aux0 + d2*exp(-zz)
            else
               aux0 = aux0 + d1*exp(-zz)
            endif
         endif
  120    continue
         term = aux1*term*p
         aux0 = aux0 - term
         p = p + 2.0
         termr = real(term)
         termi = aimag(term)
!     if(abs(termr)+abs(termi).lt.eps)30,18
         if (abs(termr) + abs(termi) .lt. eps) go to 160
         go to 120
!
!     power series method: abs(x).lt.4.0 and abs(y).lt.1.0
!
  130    continue
         aux0 = 1.0
         aux1 = -(zz + zz)
         aux2 = eps/(eps + xmag + ymag)
         term = d4*aux1
         p = 3.0
  140    continue
         aux0 = aux0 + term
         termr = real(term)
         termi = aimag(term)
!     if(abs(termr)+abs(termi).lt.aux2)26,24
         if (abs(termr) + abs(termi) .lt. aux2) go to 150
         p = p + 2.0
         term = aux1*term/p
         go to 140
  150    continue
         aux0 = d1*exp(-zz) - 2.0*z*aux0
      endif
  160 continue
      fzeta = aux0
      if (i .le. 0) return
      fzeta = -2.0*(1.0 + arg*aux0)
      return
      end function fzeta
!
!***********************************************************************
!
end module bessel_mod


    Program dbdsvdx_example

!     DBDSVDX Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dbdsvdx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: vl, vu
      Integer :: il, info, iu, ldz, n, ns
      Character (1) :: range
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:), s(:), work(:), z(:, :)
      Integer, Allocatable :: iwork(:)
!     .. Executable Statements ..
      Write (nout, *) 'DBDSVDX Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = 2*n
      Allocate (d(n), e(n-1), s(n), z(ldz,n+1), work(14*n), iwork(12*n))

!     Read the bidiagonal matrix B from data file, first
!     the diagonal elements, and then the off diagonal elements

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

!     Read range for selected singular values
      Read (nin, *) range

      If (range=='I' .Or. range=='i') Then
        Read (nin, *) il, iu
      Else If (range=='V' .Or. range=='v') Then
        Read (nin, *) vl, vu
      End If

!     Calculate the singular values and singular vectors of B.

      Call dbdsvdx('Upper', 'V', range, n, d, e, vl, vu, il, iu, ns, s, z, &
        ldz, work, iwork, info)

      If (info==0) Then
!       Print the singular values of B.

        If (range=='I' .Or. range=='i') Then
          Write (nout, 100) ns, il, iu
        Else If (range=='V' .Or. range=='v') Then
          Write (nout, 110) ns, vl, vu
        End If
        Write (nout, 120) s(1:ns)
      Else
        Write (nout, 130) '** DBDSVDX failed with INFO = ', info
      End If

100   Format (1X, I2, 1X, 'singular values of B in the index range [', I2, &
        ',', I2, ']:')
110   Format (1X, I2, 1X, 'singular values of B in the range [', F7.3, ',', &
        F7.3, ']:')
120   Format (1X, 4(3X,F11.4))
130   Format (1X, A, I10)
    End Program