      SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   CS1, RT1, RT2
      COMPLEX*16         A, B, C, SN1
*     ..
*
*  Purpose
*  =======
*
*  ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix
*     [  A         B  ]
*     [  CONJG(B)  C  ].
*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
*  eigenvector for RT1, giving the decomposition
*
*  [ CS1  CONJG(SN1) ] [    A     B ] [ CS1 -CONJG(SN1) ] = [ RT1  0  ]
*  [-SN1     CS1     ] [ CONJG(B) C ] [ SN1     CS1     ]   [  0  RT2 ].
*
*  Arguments
*  =========
*
*  A      (input) COMPLEX*16
*         The (1,1) element of the 2-by-2 matrix.
*
*  B      (input) COMPLEX*16
*         The (1,2) element and the conjugate of the (2,1) element of
*         the 2-by-2 matrix.
*
*  C      (input) COMPLEX*16
*         The (2,2) element of the 2-by-2 matrix.
*
*  RT1    (output) DOUBLE PRECISION
*         The eigenvalue of larger absolute value.
*
*  RT2    (output) DOUBLE PRECISION
*         The eigenvalue of smaller absolute value.
*
*  CS1    (output) DOUBLE PRECISION
*  SN1    (output) COMPLEX*16
*         The vector (CS1, SN1) is a unit right eigenvector for RT1.
*
*  Further Details
*  ===============
*
*  RT1 is accurate to a few ulps barring over/underflow.
*
*  RT2 may be inaccurate if there is massive cancellation in the
*  determinant A*C-B*B; higher precision or correctly rounded or
*  correctly truncated arithmetic would be needed to compute RT2
*  accurately in all cases.
*
*  CS1 and SN1 are accurate to a few ulps barring over/underflow.
*
*  Overflow is possible only if RT1 is within a factor of 5 of overflow.
*  Underflow is harmless if the input data is 0 or exceeds
*     underflow_threshold / macheps.
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   T
      COMPLEX*16         W
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAEV2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG
*     ..
*     .. Executable Statements ..
*
      IF( ABS( B ).EQ.ZERO ) THEN
         W = ONE
      ELSE
         W = DCONJG( B ) / ABS( B )
      END IF
      CALL DLAEV2( DBLE( A ), ABS( B ), DBLE( C ), RT1, RT2, CS1, T )
      SN1 = W*T
      RETURN
*
*     End of ZLAEV2
*
      END


program tarefab2
    implicit real(8) (a-h,o-z)

    g = 9.8d0
    a_l = 9.8d0

    open(10, file='saida-b2-10407962.dat')

    do j = 1, 20
        theta_0 = rand()
        Tb2 = periodob2(g, a_l, theta_0)

        write(10,'(F0.8," ",F0.8)') theta_0, Tb2
    end do

    close(10)

contains
    function periodob2(g, a_l, theta_0)
        implicit real(8) (a-h,o-z)
        parameter (pi = 4d0*atan(1d0))
        periodob2 = 2*pi*sqrt(a_l/g)*(1 + theta_0**2/16d0)
        return
    end function
end program tarefab2


 e          ! Not available. Can be calculated EXP(1.0)
 pi         ! Not available. Can be calculated 4.0*ATAN(1.0)
 SQRT(x)    ! square root
 LOG(x)     ! natural logarithm
 LOG10(x)   ! logarithm to base 10
 EXP(x)     ! exponential
 ABS(x)     ! absolute value
 FLOOR(x)   ! floor - Fortran 90 or later only
 CEILING(x) ! ceiling - Fortran 90 or later only
 x**y       ! x raised to the y power


use FEMSolverClass
implicit none

real(real64),allocatable :: K(:,:), M(:,:),eigen_vector(:),eigen_value(:),&
x(:,:),eigen_vectors(:,:),lambda_mins(:)
real(real64)::lambda_min
integer(int32) :: i

K = zeros(4,4)
M = zeros(4,4)

K(1,:) = [1.0d0, 2.0d0, 0.0d0,0.0d0]
K(2,:) = [2.0d0, 2.0d0, 3.0d0,0.0d0]
K(3,:) = [0.0d0, 3.0d0, 5.0d0,0.0d0]
K(4,:) = [0.0d0, 0.0d0, 0.0d0,1.0d0]

M(1,:) = [1.0d0, 0.0d0, 0.0d0,0.0d0]
M(2,:) = [0.0d0, 1.0d0, 0.0d0,0.0d0]
M(3,:) = [0.0d0, 0.0d0, 1.0d0,0.0d0]
M(4,:) = [0.0d0, 0.0d0, 0.0d0,1.0d0]

eigen_vector =  LOBPCG_dense_single(K,M,lambda_min)

print *, "eigen_value",lambda_min
print *, "eigen_vector",eigen_vectors

end


C       AUTHORS: MIKE MYERS AND LUCIA SPAGNUOLO
C       DATE:    MAY 8, 1989

C       Variables:
C               SCORE -> an array of test scores
C               SUM ->   sum of the test scores
C               COUNT -> counter of scores read in
C               I ->     loop counter

        REAL FUNCTION COMPAV(SCORE,COUNT)
            INTEGER SUM,COUNT,J,SCORE(5)

            DO 30 I = 1,COUNT
                SUM = SUM + SCORE(I)
30          CONTINUE
            COMPAV = SUM/COUNT
        END

        PROGRAM AVENUM
C
C                       MAIN PROGRAM
C
C       AUTHOR:   LOIS BIGBIE
C       DATE:     MAY 15, 1990
C
C       Variables:
C               MAXNOS -> maximum number of input values
C               NUMS    -> an array of numbers
C               COUNT   -> exact number of input values
C               AVG     -> average returned by COMPAV
C               I       -> loop counter
C

            PARAMETER(MAXNOS=5)
            INTEGER I, COUNT
            REAL NUMS(MAXNOS), AVG
            COUNT = 0
            DO 80 I = 1,MAXNOS
                READ (5,*,END=100) NUMS(I)
                COUNT = COUNT + 1
80          CONTINUE
100         AVG = COMPAV(NUMS, COUNT)
        END


subroutine splint(xa,ya,y2a,n,x,nrow,ncol,y)
INTEGER, INTENT(IN) :: n, nrow, ncol
REAL, INTENT(IN) :: x(nrow,ncol)
REAL, INTENT(IN) :: xa(n,1), ya(n,1), y2a(n,1)
REAL, INTENT(OUT) :: y(nrow,ncol)
INTEGER :: k, khi, klo, indr, indc
REAL :: a, b, h
klo = 1
khi = n
!print *, 'The fifth argument in Splint.f90 is', x
do indr=1,nrow
  do indc=1,ncol
       klo = 1
       khi = n
       do WHILE (khi-klo>1)
          k=(khi+klo)/2
          if (xa(k,1)>x(indr,indc)) then
            khi=k
          else
            klo=k
          end if
       END do
    h = xa(khi,1)-xa(klo,1)
    a = (xa(khi,1)-x(indr,indc))/h
    b = (x(indr,indc)-xa(klo,1))/h
    y(indr,indc) = a*ya(klo,1)+b*ya(khi,1)+((a**3-a)*y2a(klo,1)+(b**3-b)*y2a(khi,1))*(h**2)/6.0
  end do
end do
end subroutine


      program DRDRFT
c>> 1996-06-19 DRDRFT Krogh  Minor change for C conversion.
c>> 1994-10-19 DRDRFT Krogh  Changes to use M77CON
c>> 1994-08-09 DRDRFT WVS Remove '0' from format
c>> 1993-02-04 DRDRFT CLL
c>> 1989-05-07 DRDRFT FTK, CLL
c>> 1989-05-04 DRDRFT FTK, CLL
c     Demo driver for DRFT -- Multi-dimensional real Fourier transform
c     ------------------------------------------------------------------
c--D replaces "?": DR?RFT, ?RFT
c     ------------------------------------------------------------------
      integer J, J1, J2, K, L, M(2), MS, N, N2, N4, ND
      double precision A(16, 16), ONE, PI, S(3), SIG, SIGD, TEMP, ZERO
      parameter (PI = 3.1415926535897932384D0)
      parameter (ONE = 1.D0)
      parameter (ZERO = 0.D0)
      data M / 4, 4 /, ND / 2 /
c     ------------------------------------------------------------------
c                         Start of code -- Construct A
      N = 2 ** M(1)
      N2 = N /2
      N4 = N2 / 2
      SIGD = PI / N2
      do 20 J1 = 1, N
         do 10 J2 = 1, N
            A(J1, J2) = ZERO
            if (abs(J1-N2-1) + abs(J2-N2-1) .le. N4) A(J1, J2) = ONE
   10    continue
   20 continue
c     ------------------------------------------------------------------
c                Compute Fourier transform and apply sigma factors
      MS = 0
      call DRFT (A, 'A', M, ND, MS, S)
      do 50 J1 = 1, N, 2
         A(J1, N2+1) = ZERO
         A(J1+1, N2+1) = ZERO
         do 40 J2 = 1, N2
            SIG = ONE
            if (J1 .EQ. 1) then
c                            No change in SIG due to J
               if (J2 .NE. 1) then
                  J = J2 - 1
                  K = 1
               else
                  A(2, 1) = ZERO
                  go to 40
               end if
            else
               J = J1 / 2
               K = 0
            end if
c                         Get nontrivial sigma factors * SIG
   30       continue
            if (J .LT. N4) then
               TEMP = S(J)
            else if (J .EQ. N4) then
               TEMP = ONE
            else
               TEMP = S(N2-J)
            end if
            SIG = SIG * TEMP / (SIGD * dble(J))
            if (K .EQ. 0) then
               if (J2 .NE. 1) then
                  J = J2 - 1
                  K = 1
                  go to 30
               end if
            else
c                                       Apply sigma factors
               if (J1 .EQ. 1) then
                  A(1, N-J2+2) = ZERO
                  A(2, N-J2+2) = ZERO
               else
                  A(J1, N-J2+2) = SIG * A(J1, N-J2+2)
                  A(J1+1, N-J2+2) = SIG * A(J1+1, N-J2+2)
               end if
            end if
            A(J1, J2) = SIG * A(J1, J2)
            A(J1+1, J2) = SIG * A(J1+1, J2)
   40    continue
   50 continue
      call DRFT (A, 'S', M, ND, MS, S)
      print '(/'' Smoothed A'')'
      do 60 L = 1, 9
         print'(9f8.4)', (A(L,N), N = 1, 9)
   60 continue
      stop
      end


! In the 20x20 grid below, four numbers along a diagonal line have been marked in red.
!
!    08 02 22 97 38 15 00 40 00 75 04 05 07 78 52 12 50 77 91 08
!    49 49 99 40 17 81 18 57 60 87 17 40 98 43 69 48 04 56 62 00
!    81 49 31 73 55 79 14 29 93 71 40 67 53 88 30 03 49 13 36 65
!    52 70 95 23 04 60 11 42 69 24 68 56 01 32 56 71 37 02 36 91
!    22 31 16 71 51 67 63 89 41 92 36 54 22 40 40 28 66 33 13 80
!    24 47 32 60 99 03 45 02 44 75 33 53 78 36 84 20 35 17 12 50
!    32 98 81 28 64 23 67 10[26]38 40 67 59 54 70 66 18 38 64 70
!    67 26 20 68 02 62 12 20 95[63]94 39 63 08 40 91 66 49 94 21
!    24 55 58 05 66 73 99 26 97 17[78]78 96 83 14 88 34 89 63 72
!    21 36 23 09 75 00 76 44 20 45 35[14]00 61 33 97 34 31 33 95
!    78 17 53 28 22 75 31 67 15 94 03 80 04 62 16 14 09 53 56 92
!    16 39 05 42 96 35 31 47 55 58 88 24 00 17 54 24 36 29 85 57
!    86 56 00 48 35 71 89 07 05 44 44 37 44 60 21 58 51 54 17 58
!    19 80 81 68 05 94 47 69 28 73 92 13 86 52 17 77 04 89 55 40
!    04 52 08 83 97 35 99 16 07 97 57 32 16 26 26 79 33 27 98 66
!    88 36 68 87 57 62 20 72 03 46 33 67 46 55 12 32 63 93 53 69
!    04 42 16 73 38 25 39 11 24 94 72 18 08 46 29 32 40 62 76 36
!    20 69 36 41 72 30 23 88 34 62 99 69 82 67 59 85 74 04 36 16
!    20 73 35 29 78 31 90 01 74 31 49 71 48 86 81 16 23 57 05 54
!    01 70 54 71 83 51 54 69 16 92 33 48 61 43 52 01 89 19 67 48
!
! The product of these numbers is 26 x 63 x 78 x 14 = 1788696.
!
! What is the greatest product of four adjacent numbers in the same
! direction (up, down, left, right, or diagonally) in the 20x20 grid?
module Problem11

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 11. Largest product in a grid.'

        write (*, '(A, I)') 'Product 1: ', product1()
    end subroutine

    pure function product1()
        integer :: product1

        integer :: horizontal
        integer :: vertical
        integer :: location
        integer :: value

        integer, dimension(20, 20) :: matrix;

        ! initial values
        product1 = 0
        matrix   = transpose(reshape((/08, 02, 22, 97, 38, 15, 00, 40, 00, 75, 04, 05, 07, 78, 52, 12, 50, 77, 91, 08, 49, 49, 99, 40, 17, 81, 18, 57, 60, 87, 17, 40, 98, 43, 69, 48, 04, 56, 62, 00, 81, 49, 31, 73, 55, 79, 14, 29, 93, 71, 40, 67, 53, 88, 30, 03, 49, 13, 36, 65, 52, 70, 95, 23, 04, 60, 11, 42, 69, 24, 68, 56, 01, 32, 56, 71, 37, 02, 36, 91, 22, 31, 16, 71, 51, 67, 63, 89, 41, 92, 36, 54, 22, 40, 40, 28, 66, 33, 13, 80, 24, 47, 32, 60, 99, 03, 45, 02, 44, 75, 33, 53, 78, 36, 84, 20, 35, 17, 12, 50, 32, 98, 81, 28, 64, 23, 67, 10, 26, 38, 40, 67, 59, 54, 70, 66, 18, 38, 64, 70, 67, 26, 20, 68, 02, 62, 12, 20, 95, 63, 94, 39, 63, 08, 40, 91, 66, 49, 94, 21, 24, 55, 58, 05, 66, 73, 99, 26, 97, 17, 78, 78, 96, 83, 14, 88, 34, 89, 63, 72, 21, 36, 23, 09, 75, 00, 76, 44, 20, 45, 35, 14, 00, 61, 33, 97, 34, 31, 33, 95, 78, 17, 53, 28, 22, 75, 31, 67, 15, 94, 03, 80, 04, 62, 16, 14, 09, 53, 56, 92, 16, 39, 05, 42, 96, 35, 31, 47, 55, 58, 88, 24, 00, 17, 54, 24, 36, 29, 85, 57, 86, 56, 00, 48, 35, 71, 89, 07, 05, 44, 44, 37, 44, 60, 21, 58, 51, 54, 17, 58, 19, 80, 81, 68, 05, 94, 47, 69, 28, 73, 92, 13, 86, 52, 17, 77, 04, 89, 55, 40, 04, 52, 08, 83, 97, 35, 99, 16, 07, 97, 57, 32, 16, 26, 26, 79, 33, 27, 98, 66, 88, 36, 68, 87, 57, 62, 20, 72, 03, 46, 33, 67, 46, 55, 12, 32, 63, 93, 53, 69, 04, 42, 16, 73, 38, 25, 39, 11, 24, 94, 72, 18, 08, 46, 29, 32, 40, 62, 76, 36, 20, 69, 36, 41, 72, 30, 23, 88, 34, 62, 99, 69, 82, 67, 59, 85, 74, 04, 36, 16, 20, 73, 35, 29, 78, 31, 90, 01, 74, 31, 49, 71, 48, 86, 81, 16, 23, 57, 05, 54, 01, 70, 54, 71, 83, 51, 54, 69, 16, 92, 33, 48, 61, 43, 52, 01, 89, 19, 67, 48/), shape(matrix)))

        do horizontal = 1, 20
            do vertical = 1, 17
                value = 1

                do location = vertical, vertical + 3
                    value = value * matrix(location, horizontal)
                end do

                if (value .gt. product1) then
                    product1 = value
                end if
            end do
        end do

        do vertical = 1, 20
            do horizontal = 1, 17
                value = 1

                do location = horizontal, horizontal + 3
                    value = value * matrix(vertical, location)
                end do

                if (value .gt. product1) then
                    product1 = value
                end if
            end do
        end do

        do horizontal = 17, 1, -1
            do vertical = 1, 17
                value = 1

                value = value * matrix(vertical, horizontal) &
                        * matrix(vertical + 1, horizontal + 1) &
                        * matrix(vertical + 2, horizontal + 2) &
                        * matrix(vertical + 3, horizontal + 3)

                if (value .gt. product1) then
                    product1 = value
                end if
            end do
        end do

        do horizontal = 4, 20
            do vertical = 1, 17
                value = 1

                value = value * matrix(vertical, horizontal) &
                        * matrix(vertical + 1, horizontal - 1) &
                        * matrix(vertical + 2, horizontal - 2) &
                        * matrix(vertical + 3, horizontal - 3)

                if (value .gt. product1) then
                    product1 = value
                end if
            end do
        end do
    end function
end module


*> \brief \b SBDT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK,
*                          RESID )
*
*       .. Scalar Arguments ..
*       INTEGER            KD, LDA, LDPT, LDQ, M, N
*       REAL               RESID
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), D( * ), E( * ), PT( LDPT, * ),
*      $                   Q( LDQ, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SBDT01 reconstructs a general matrix A from its bidiagonal form
*>    A = Q * B * P**T
*> where Q (m by min(m,n)) and P**T (min(m,n) by n) are orthogonal
*> matrices and B is bidiagonal.
*>
*> The test ratio to test the reduction is
*>    RESID = norm(A - Q * B * P**T) / ( n * norm(A) * EPS )
*> where EPS is the machine precision.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrices A and Q.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrices A and P**T.
*> \endverbatim
*>
*> \param[in] KD
*> \verbatim
*>          KD is INTEGER
*>          If KD = 0, B is diagonal and the array E is not referenced.
*>          If KD = 1, the reduction was performed by xGEBRD; B is upper
*>          bidiagonal if M >= N, and lower bidiagonal if M < N.
*>          If KD = -1, the reduction was performed by xGBBRD; B is
*>          always upper bidiagonal.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*>          Q is REAL array, dimension (LDQ,N)
*>          The m by min(m,n) orthogonal matrix Q in the reduction
*>          A = Q * B * P**T.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*>          LDQ is INTEGER
*>          The leading dimension of the array Q.  LDQ >= max(1,M).
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (min(M,N))
*>          The diagonal elements of the bidiagonal matrix B.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is REAL array, dimension (min(M,N)-1)
*>          The superdiagonal elements of the bidiagonal matrix B if
*>          m >= n, or the subdiagonal elements of B if m < n.
*> \endverbatim
*>
*> \param[in] PT
*> \verbatim
*>          PT is REAL array, dimension (LDPT,N)
*>          The min(m,n) by n orthogonal matrix P**T in the reduction
*>          A = Q * B * P**T.
*> \endverbatim
*>
*> \param[in] LDPT
*> \verbatim
*>          LDPT is INTEGER
*>          The leading dimension of the array PT.
*>          LDPT >= max(1,min(M,N)).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (M+N)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is REAL
*>          The test ratio:
*>          norm(A - Q * B * P**T) / ( n * norm(A) * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE SBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK,
     $                   RESID )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            KD, LDA, LDPT, LDQ, M, N
      REAL               RESID
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), D( * ), E( * ), PT( LDPT, * ),
     $                   Q( LDQ, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      REAL               ANORM, EPS
*     ..
*     .. External Functions ..
      REAL               SASUM, SLAMCH, SLANGE
      EXTERNAL           SASUM, SLAMCH, SLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SGEMV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
*     Compute A - Q * B * P**T one column at a time.
*
      RESID = ZERO
      IF( KD.NE.0 ) THEN
*
*        B is bidiagonal.
*
         IF( KD.NE.0 .AND. M.GE.N ) THEN
*
*           B is upper bidiagonal and M >= N.
*
            DO 20 J = 1, N
               CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
               DO 10 I = 1, N - 1
                  WORK( M+I ) = D( I )*PT( I, J ) + E( I )*PT( I+1, J )
   10          CONTINUE
               WORK( M+N ) = D( N )*PT( N, J )
               CALL SGEMV( 'No transpose', M, N, -ONE, Q, LDQ,
     $                     WORK( M+1 ), 1, ONE, WORK, 1 )
               RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
   20       CONTINUE
         ELSE IF( KD.LT.0 ) THEN
*
*           B is upper bidiagonal and M < N.
*
            DO 40 J = 1, N
               CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
               DO 30 I = 1, M - 1
                  WORK( M+I ) = D( I )*PT( I, J ) + E( I )*PT( I+1, J )
   30          CONTINUE
               WORK( M+M ) = D( M )*PT( M, J )
               CALL SGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
     $                     WORK( M+1 ), 1, ONE, WORK, 1 )
               RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
   40       CONTINUE
         ELSE
*
*           B is lower bidiagonal.
*
            DO 60 J = 1, N
               CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
               WORK( M+1 ) = D( 1 )*PT( 1, J )
               DO 50 I = 2, M
                  WORK( M+I ) = E( I-1 )*PT( I-1, J ) +
     $                          D( I )*PT( I, J )
   50          CONTINUE
               CALL SGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
     $                     WORK( M+1 ), 1, ONE, WORK, 1 )
               RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
   60       CONTINUE
         END IF
      ELSE
*
*        B is diagonal.
*
         IF( M.GE.N ) THEN
            DO 80 J = 1, N
               CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
               DO 70 I = 1, N
                  WORK( M+I ) = D( I )*PT( I, J )
   70          CONTINUE
               CALL SGEMV( 'No transpose', M, N, -ONE, Q, LDQ,
     $                     WORK( M+1 ), 1, ONE, WORK, 1 )
               RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
   80       CONTINUE
         ELSE
            DO 100 J = 1, N
               CALL SCOPY( M, A( 1, J ), 1, WORK, 1 )
               DO 90 I = 1, M
                  WORK( M+I ) = D( I )*PT( I, J )
   90          CONTINUE
               CALL SGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
     $                     WORK( M+1 ), 1, ONE, WORK, 1 )
               RESID = MAX( RESID, SASUM( M, WORK, 1 ) )
  100       CONTINUE
         END IF
      END IF
*
*     Compute norm(A - Q * B * P**T) / ( n * norm(A) * EPS )
*
      ANORM = SLANGE( '1', M, N, A, LDA, WORK )
      EPS = SLAMCH( 'Precision' )
*
      IF( ANORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         IF( ANORM.GE.RESID ) THEN
            RESID = ( RESID / ANORM ) / ( REAL( N )*EPS )
         ELSE
            IF( ANORM.LT.ONE ) THEN
               RESID = ( MIN( RESID, REAL( N )*ANORM ) / ANORM ) /
     $                 ( REAL( N )*EPS )
            ELSE
               RESID = MIN( RESID / ANORM, REAL( N ) ) /
     $                 ( REAL( N )*EPS )
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of SBDT01
*
      END


      subroutine setmb_msbar
c--- set up the value of the running b-mass in the MS-bar scheme,
c--- evaluated at the pole mass (mb)
c--- expressions are taken from
c--- J.~Fleischer, F.~Jegerlehner, O.~V.~Tarasov and O.~L.~Veretin,
c--- %``Two-loop {QCD} corrections of the massive fermion propagator,''
c--- Nucl.\ Phys.\ B {\bf 539}, 671 (1999)
c--- [Erratum-ibid.\ B {\bf 571}, 511 (2000)]
c--- [arXiv:hep-ph/9803493].
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'msbarmasses.f'
      include 'couple.f'
      include 'part.f'
      double precision alphas,c1,c2,a,zeta3,i31
      parameter(zeta3=1.20205690315959428539d0)

      if (mb_msbar .lt. 0d0) then
        c1=4d0*Cf
        c2=0d0
c--- calculate the MS-bar mass from the pole mass
        if (part .eq. 'lord') then
          a=alphas(mb,amz,1)/(4d0*pi)
        else
          a=alphas(mb,amz,2)/(4d0*pi)
          i31=3d0/2d0*zeta3-6d0*pisqo6*dlog(2d0)
          c2=Cf*xn*(1111d0/24d0-8d0*pisqo6-4d0*i31)
     .      -Cf*half*dfloat(nf-1)*(71d0/6d0+8d0*pisqo6)
     .      +Cf**2*(121d0/8d0+30d0*pisqo6+8d0*i31)
     .      -12d0*Cf*half*(1d0-2d0*pisqo6)
        endif
        mb_msbar=mb/(1d0+c1*a+c2*a**2)
      endif

c--- For comparison, these were the choices made in previous publications:
c--- mb(mb)=4.20 is our choice for the H+b paper
c--- mb(mb)=4.25 is the value used in the Les Houches write-up

      write(6,99) mb_msbar

      return

 99   format(/,
     .       ' ************* Running b-mass at pole mass **********'/,
     .       ' *                                                  *'/,
     .       ' *                mb_MSbar(mb)  = ',f8.4,'          *'/,
     .       ' ****************************************************')

      end


program prog3
implicit none

double precision, dimension(1:2,1:2) :: matrix
double precision :: a,b,det

matrix(1,1) = 1d0
matrix(1,2) = 4d0
matrix(2,1) = 3d0
matrix(2,2) = 2d0

a = matrix(1,1)*matrix(2,2)
b = matrix(1,2)*matrix(2,1)
det = a-b

write(*,*)det

end program prog3


	subroutine gaussj(a,n,np,b,m,mp,istat)
c  gaussj.f
c  Linear equation solution bu Gauss-jordan elimination; from
c  Numerical Recipies, p. 28.
c  A is n by n matrix; physical dimensions np by np
c  b is n by m matrix of m right-side vectors, stored np by mp
c  output replaces a by its inverse, and b by solution vectors
c    Simple case, has m = 1.
c   returns istat=-1 if singular, -2 if bad-dimensions, 0 otherwise

c  nmax should ge .ge. n
	parameter (nmax = 2048)
	dimension a(np,np), b(np,mp)
	dimension ipiv(nmax),indxr(nmax), indxc(nmax)

	istat = 0
	do 11 j=1,n
	  ipiv(j) = 0
11	continue

c --- main loop over columns
	do 22 i=1,n
	  big = 0.
c --- outer loop of search for pivot elements
	  do 13 j=1,n
	    if (ipiv(j).ne.1) then
	      do 12 k=1,n
		if (ipiv(k).eq.0) then
		  if (abs(a(j,k)).ge.big) then
		    big = abs(a(j,k))
		    irow = j
		    icol = k
		  end if
		else if (ipiv(k).gt.1) then
		  print *,"GAUSSJ:  Singular Matrix"
		  istat = -1
		  return
	  	end if
12	      continue
	    end if
13	  continue
	  ipiv(icol) = ipiv(icol) + 1
c --- pivots now interchanged: indxc(i) = col. for ith piv. elem.
c	indxr(i) = row of original location of pivot.
	  if (irow.ne.icol) then
	    do 14 l=1,n
	      dum = a(irow,l)
	      a(irow,l) = a(icol,l)
	      a(icol,l) = dum
14	    continue
	    do 15 l=1,m
	      dum = b(irow,l)
	      b(irow,l) = b(icol,l)
	      b(icol,l) = dum
15	    continue
	  end if

c--- divide pivot row by pivot elem. at irow,icol
	  indxr(i) = irow
	  indxc(i) = icol
	  if (a(icol,icol).eq.0.) then
	    print *,"GJINV:  Singular Matrix"
	    istat = -1
	    return
	  end if
	  pivinv=1./a(icol,icol)
	  a(icol,icol) = 1.
	  do 16 l=1,n
	    a(icol,l) = a(icol,l)*pivinv
16	  continue
	  do 17 l=1,m
	    b(icol,l) = b(icol,l)*pivinv
17	  continue
c  --- reduce rows now
	  do 21 ll=1,n
	    if (ll.ne.icol) then
	      dum=a(ll,icol)
	      a(ll,icol) = 0.
	      do 18 l=1,n
		a(ll,l)=a(ll,l)-a(icol,l)*dum
18	       continue
	      do 19 l=1,m
		b(ll,l)=b(ll,l)-b(icol,l)*dum
19	      continue
	    end if
21	  continue
22	continue

c  -- unscramble indexing
	do 24 l=n,1,-1
	  if(indxr(l).ne.indxc(l)) then
	    do 23 k=1,n
		dum=a(k,indxr(l))
		a(k,indxr(l))=a(k,indxc(l))
		a(k,indxc(l))=dum
23	    continue
	  end if
24	continue
	istat = 0
	return
	end

	subroutine dgaussj(a,n,np,b,m,mp,istat)
c  gaussj.f
c  Linear equation solution bu Gauss-jordan elimination; from
c  Numerical Recipies, p. 28.
c
c *** THIS is DOUBLE PRECISION version
C
c  A is n by n matrix; physical dimensions np by np
c  b is n by m matrix of m right-side vectors, stored np by mp
c  output replaces a by its inverse, and b by solution vectors
c    Simple case, has m = 1.
c   returns istat=-1 if singular, 0 otherwise

c  nmax should ge .ge. n
	implicit double precision (a-h,o-z)
	parameter (nmax = 1024)
	dimension a(np,np), b(np,mp)
	dimension ipiv(nmax),indxr(nmax), indxc(nmax)

	if (n.gt.nmax) then
	  print *,'GAUSSJ:  n>nmax; n=',n,', nmax=',nmax
	  istat=-2
	  return
	end if

	istat = 0
	do 11 j=1,n
	  ipiv(j) = 0
11	continue

c --- main loop over columns
	do 22 i=1,n
	  big = 0.
c --- outer loop of search for pivot elements
	  do 13 j=1,n
	    if (ipiv(j).ne.1) then
	      do 12 k=1,n
		if (ipiv(k).eq.0) then
		  if (abs(a(j,k)).ge.big) then
		    big = abs(a(j,k))
		    irow = j
		    icol = k
		  end if
		else if (ipiv(k).gt.1) then
		  print *,"GAUSSJ:  Singular Matrix"
		  istat = -1
		  return
	  	end if
12	      continue
	    end if
13	  continue
	  ipiv(icol) = ipiv(icol) + 1
c --- pivots now interchanged: indxc(i) = col. for ith piv. elem.
c	indxr(i) = row of original location of pivot.
	  if (irow.ne.icol) then
	    do 14 l=1,n
	      dum = a(irow,l)
	      a(irow,l) = a(icol,l)
	      a(icol,l) = dum
14	    continue
	    do 15 l=1,m
	      dum = b(irow,l)
	      b(irow,l) = b(icol,l)
	      b(icol,l) = dum
15	    continue
	  end if

c--- divide pivot row by pivot elem. at irow,icol
	  indxr(i) = irow
	  indxc(i) = icol
	  if (a(icol,icol).eq.0.) then
	    print *,"GJINV:  Singular Matrix"
	    istat = -1
	    return
	  end if
	  pivinv=1./a(icol,icol)
	  a(icol,icol) = 1.
	  do 16 l=1,n
	    a(icol,l) = a(icol,l)*pivinv
16	  continue
	  do 17 l=1,m
	    b(icol,l) = b(icol,l)*pivinv
17	  continue
c  --- reduce rows now
	  do 21 ll=1,n
	    if (ll.ne.icol) then
	      dum=a(ll,icol)
	      a(ll,icol) = 0.
	      do 18 l=1,n
		a(ll,l)=a(ll,l)-a(icol,l)*dum
18	       continue
	      do 19 l=1,m
		b(ll,l)=b(ll,l)-b(icol,l)*dum
19	      continue
	    end if
21	  continue
22	continue

c  -- unscramble indexing
	do 24 l=n,1,-1
	  if(indxr(l).ne.indxc(l)) then
	    do 23 k=1,n
		dum=a(k,indxr(l))
		a(k,indxr(l))=a(k,indxc(l))
		a(k,indxc(l))=dum
23	    continue
	  end if
24	continue
	istat = 0
	return
	end


module ps_grav

  use amrex_fort_module, only : rt => amrex_real

  implicit none

  real(rt), private, save :: dm_const,dm_const2
  logical, private, save :: isnt_init = .true.
  public :: ps_grav_init,ps_grav_accel,ps_grav_phi
  contains

      subroutine ps_grav_init()
        use fundamental_constants_module, only : Gconst,Mpc,M_s
        use probdata_module, only : dcenx,dceny,dcenz,dmconc,dmmass,dmscale
        implicit none
        if(isnt_init) then
          dm_const = -(dmmass/M_s)*Gconst / (log(1.0d0+dmconc) - dmconc/(1.0d0+dmconc))
          dm_const2 = dmconc/(dmscale/Mpc)
          isnt_init = .false.
        else
          write(*,*)'ps_grav is already initialized, why are we here?'
        endif
      end subroutine ps_grav_init

!     This is an example of how to specify a radial profile
!     Note that r_c and rho_c must be specified in probdata_module
      pure function ps_grav_accel(r) result(g)
        implicit none
        real(rt), intent(in) :: r!,smbh_const
        real(rt)             :: g
!         ! put function for g(r) in here
        g = dm_const*(dlog(1.0d0+dm_const2*r)/(r*r)-dm_const2 &
               /(r*(1.0d0+r*dm_const2)))
      end function ps_grav_accel

      pure function ps_grav_phi(r) result(g)
        implicit none
        real(rt), intent(in) :: r
        real(rt)             :: g
!         ! put function for g(r) in here
        g = -dm_const*dlog(1.0d0+r*dm_const2)/r
      end function ps_grav_phi
end module ps_grav

subroutine fort_prescribe_grav (lo,hi,dx, &
     grav,g_l1,g_l2,g_l3,g_h1,g_h2,g_h3,&
     problo,add)

  use probdata_module, only : dcenx,dceny,dcenz
  use amrex_constants_module, only : HALF
  use ps_grav, only : ps_grav_accel
  implicit none
  integer          :: g_l1,g_l2,g_l3,g_h1,g_h2,g_h3,add
  integer          :: lo(3),hi(3)
  real(rt) :: grav(g_l1:g_h1,g_l2:g_h2,g_l3:g_h3,3)
  real(rt) :: dx(3)
  real(rt) :: problo(3)

  integer          :: i,j,k
  real(rt) :: fort_prescribe_grav_gravityprofile
  real(rt) :: x,y,z,y2,z2
  real(rt) :: r,maggrav
  real(rt) :: dxm,r1
  dxm = min(dx(1),dx(2),dx(3))
!
! This is an example of how to use the radial profile above.
!
  if (add.eq.0) then
     do k = lo(3), hi(3)
        z = problo(3) + (dble(k)+HALF) * dx(3) - dcenz
        z2 = z*z
        do j = lo(2), hi(2)
           y = problo(2) + (dble(j)+HALF) * dx(2) - dceny
           y2 = y*y
           do i = lo(1), hi(1)
              x = problo(1) + (dble(i)+HALF) * dx(1) - dcenx
              r1 = dsqrt(x*x+y2+z2)
              r = max(dxm,r1)

              maggrav = ps_grav_accel(r)

              !              Put in angular dependence
              grav(i,j,k,1) = maggrav*x/r
              grav(i,j,k,2) = maggrav*y/r
              grav(i,j,k,3) = maggrav*z/r
           enddo
        enddo
     enddo
  else
     do k = lo(3), hi(3)
        z = problo(3) + (dble(k)+HALF) * dx(3) - dcenz
        z2 = z*z
        do j = lo(2), hi(2)
           y = problo(2) + (dble(j)+HALF) * dx(2) - dceny
           y2 = y*y
           do i = lo(1), hi(1)
              x = problo(1) + (dble(i)+HALF) * dx(1) - dcenx
              r1 = dsqrt(x*x+y2+z2)
              r = max(dxm,r1)

              maggrav = ps_grav_accel(r)

              !              Put in angular dependence
              grav(i,j,k,1) = grav(i,j,k,1) + maggrav*x/r
              grav(i,j,k,2) = grav(i,j,k,2) + maggrav*y/r
              grav(i,j,k,3) = grav(i,j,k,3) + maggrav*z/r
           enddo
        enddo
     enddo
  endif

end subroutine fort_prescribe_grav


MODULE Grid_Interpolation

!      ALGORITHM 760, COLLECTED ALGORITHMS FROM ACM.
!      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
!      VOL. 22, NO. 3, September, 1996, P.  357--361.

IMPLICIT NONE
PRIVATE
PUBLIC  :: rgbi3p, rgsf3p

CONTAINS

SUBROUTINE rgbi3p(md, nxd, nyd, xd, yd, zd, nip, xi, yi, zi, ier)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-11  Time: 10:11:03

! Typo in definition of IDLT in SUBROUTINE RGPD3P fixed by Jason Blevins
! Date: 2015-06-21  Time: 00:22:26

! Rectangular-grid bivariate interpolation
! (a master subroutine of the RGBI3P/RGSF3P subroutine package)

! Hiroshi Akima
! U.S. Department of Commerce, NTIA/ITS
! Version of 1995/08

! This subroutine performs interpolation of a bivariate function, z(x,y), on a
! rectangular grid in the x-y plane.  It is based on the revised Akima method.

! In this subroutine, the interpolating function is a piecewise function
! composed of a set of bicubic (bivariate third-degree) polynomials, each
! applicable to a rectangle of the input grid in the x-y plane.
! Each polynomial is determined locally.

! This subroutine has the accuracy of a bicubic polynomial, i.e., it
! interpolates accurately when all data points lie on a surface of a
! bicubic polynomial.

! The grid lines can be unevenly spaced.

! The input arguments are
!   MD  = mode of computation
!       = 1 for new XD, YD, or ZD data (default)
!       = 2 for old XD, YD, and ZD data,
!   NXD = number of the input-grid data points in the x coordinate
!         (must be 2 or greater),
!   NYD = number of the input-grid data points in the y coordinate
!         (must be 2 or greater),
!   XD  = array of dimension NXD containing the x coordinates of the
!         input-grid data points (must be in a monotonic increasing order),
!   YD  = array of dimension NYD containing the y coordinates of the
!         input-grid data points (must be in a monotonic increasing order),
!   ZD  = two-dimensional array of dimension NXD*NYD
!         containing the z(x,y) values at the input-grid data points,
!   NIP = number of the output points at which interpolation
!         of the z value is desired (must be 1 or greater),
!   XI  = array of dimension NIP containing the x coordinates
!         of the output points,
!   YI  = array of dimension NIP containing the y coordinates
!         of the output points.

! The output arguments are
!   ZI  = array of dimension NIP where the interpolated z
!         values at the output points are to be stored,
!   IER = error flag
!       = 0 for no errors
!       = 1 for NXD = 1 or less
!       = 2 for NYD = 1 or less
!       = 3 for identical XD values or XD values out of sequence
!       = 4 for identical YD values or YD values out of sequence
!       = 5 for NIP = 0 or less.

! N.B. The workspace has been removed from the argument list.
!   WK  = three dimensional array of dimension 3*NXD*NYD used internally
!         as a work area.

! The very fisrt call to this subroutine and the call with a new XD, YD, and
! ZD array must be made with MD=1.  The call with MD=2 must be preceded by
! another call with the same XD, YD, and ZD arrays.  Between the call with
! MD=2 and its preceding call, the WK array must not be disturbed.

! The constant in the PARAMETER statement below is
!   NIPIMX = maximum number of output points to be processed at a time.
! The constant value has been selected empirically.

! This subroutine calls the RGPD3P, RGLCTN, and RGPLNL subroutines.

! Specification statements
!     .. Parameters ..

INTEGER, INTENT(IN)   :: md
INTEGER, INTENT(IN)   :: nxd
INTEGER, INTENT(IN)   :: nyd
REAL, INTENT(IN)      :: xd(nxd)
REAL, INTENT(IN)      :: yd(nyd)
REAL, INTENT(IN OUT)  :: zd(nxd,nyd)
INTEGER, INTENT(IN)   :: nip
REAL, INTENT(IN OUT)  :: xi(nip)
REAL, INTENT(IN OUT)  :: yi(nip)
REAL, INTENT(IN OUT)  :: zi(nip)
INTEGER, INTENT(OUT)  :: ier

!     ..
!     .. Local Scalars ..
INTEGER, PARAMETER  :: nipimx=51

INTEGER  :: iip, ix, iy, nipi
!     ..
!     .. Local Arrays ..
INTEGER  :: inxi(nipimx), inyi(nipimx)

! Allocate workspace
REAL  :: wk(3,nxd,nyd)
!     ..
!     .. External Subroutines ..
! EXTERNAL         rglctn, rgpd3p, rgplnl
!     ..
!     .. Intrinsic Functions ..
! INTRINSIC        MIN
!     ..

! Preliminary processing
! Error check
IF (nxd <= 1) GO TO 40
IF (nyd <= 1) GO TO 50
DO  ix = 2,nxd
  IF (xd(ix) <= xd(ix-1)) GO TO 60
END DO
DO  iy = 2,nyd
  IF (yd(iy) <= yd(iy-1)) GO TO 70
END DO
IF (nip <= 0) GO TO 80
ier = 0

! Calculation
! Estimates partial derivatives at all input-grid data points (for MD=1).
IF (md /= 2) THEN
  CALL rgpd3p(nxd, nyd, xd, yd, zd, wk)
END IF

! DO-loop with respect to the output point
! Processes NIPIMX output points, at most, at a time.
DO  iip = 1,nip,nipimx
  nipi = MIN(nip- (iip-1),nipimx)
! Locates the output points.
  CALL rglctn(nxd, nyd, xd, yd, nipi, xi(iip), yi(iip), inxi, inyi)

! Calculates the z values at the output points.
  CALL rgplnl(nxd, nyd, xd, yd, zd, wk, nipi, xi(iip), yi(iip), inxi, inyi, &
              zi(iip))
END DO
RETURN

! Error exit
40 WRITE (*,FMT=9000)
ier = 1
GO TO 90
50 WRITE (*,FMT=9010)
ier = 2
GO TO 90
60 WRITE (*,FMT=9020) ix,xd(ix)
ier = 3
GO TO 90
70 WRITE (*,FMT=9030) iy,yd(iy)
ier = 4
GO TO 90
80 WRITE (*,FMT=9040)
ier = 5
90 WRITE (*,FMT=9050) nxd,nyd,nip
RETURN

! Format statements for error messages
9000 FORMAT (/' *** RGBI3P Error 1: NXD = 1 or less')
9010 FORMAT (/' *** RGBI3P Error 2: NYD = 1 or less')
9020 FORMAT (/' *** RGBI3P Error 3: Identical XD values or',  &
    ' XD values out of sequence'/ '    IX =', i6, ',  XD(IX) =', e11.3)
9030 FORMAT (/' *** RGBI3P Error 4: Identical YD values or',  &
    ' YD values out of sequence',/,'    IY =',i6,',  YD(IY) =', e11.3)
9040 FORMAT (/' *** RGBI3P Error 5: NIP = 0 or less')
9050 FORMAT ('    NXD =', i5,',  NYD =', i5,',  NIP =', i5/)
END SUBROUTINE rgbi3p

SUBROUTINE rgsf3p(md, nxd, nyd, xd, yd, zd, nxi, xi, nyi, yi, zi, ier)

! Rectangular-grid surface fitting
! (a master subroutine of the RGBI3P/RGSF3P subroutine package)

! Hiroshi Akima
! U.S. Department of Commerce, NTIA/ITS
! Version of 1995/08

! This subroutine performs surface fitting by interpolating values of a
! bivariate function, z(x,y), on a rectangular grid in the x-y plane.
! It is based on the revised Akima method.

! In this subroutine, the interpolating function is a piecewise function
! composed of a set of bicubic (bivariate third-degree) polynomials, each
! applicable to a rectangle of the input grid in the x-y plane.
! Each polynomial is determined locally.

! This subroutine has the accuracy of a bicubic polynomial, i.e., it fits the
! surface accurately when all data points lie on a surface of a bicubic
! polynomial.

! The grid lines of the input and output data can be unevenly spaced.

! The input arguments are
!   MD  = mode of computation
!       = 1 for new XD, YD, or ZD data (default)
!       = 2 for old XD, YD, and ZD data,
!   NXD = number of the input-grid data points in the x
!         coordinate (must be 2 or greater),
!   NYD = number of the input-grid data points in the y
!         coordinate (must be 2 or greater),
!   XD  = array of dimension NXD containing the x coordinates
!         of the input-grid data points (must be in a
!         monotonic increasing order),
!   YD  = array of dimension NYD containing the y coordinates
!         of the input-grid data points (must be in a
!         monotonic increasing order),
!   ZD  = two-dimensional array of dimension NXD*NYD
!         containing the z(x,y) values at the input-grid data points,
!   NXI = number of output grid points in the x coordinate
!         (must be 1 or greater),
!   XI  = array of dimension NXI containing the x coordinates
!         of the output grid points,
!   NYI = number of output grid points in the y coordinate
!         (must be 1 or greater),
!   YI  = array of dimension NYI containing the y coordinates
!         of the output grid points.

! The output arguments are
!   ZI  = two-dimensional array of dimension NXI*NYI, where the interpolated
!         z values at the output grid points are to be stored,
!   IER = error flag
!       = 0 for no error
!       = 1 for NXD = 1 or less
!       = 2 for NYD = 1 or less
!       = 3 for identical XD values or XD values out of sequence
!       = 4 for identical YD values or YD values out of sequence
!       = 5 for NXI = 0 or less
!       = 6 for NYI = 0 or less.

! N.B. The workspace has been removed from the argument list.
!   WK  = three-dimensional array of dimension 3*NXD*NYD used internally
!         as a work area.

! The very first call to this subroutine and the call with a new XD, YD, or
! ZD array must be made with MD=1.  The call with MD=2 must be preceded by
! another call with the same XD, YD, and ZD arrays.  Between the call with
! MD=2 and its preceding call, the WK array must not be disturbed.

! The constant in the PARAMETER statement below is
!   NIPIMX = maximum number of output points to be processed at a time.
! The constant value has been selected empirically.

! This subroutine calls the RGPD3P, RGLCTN, and RGPLNL subroutines.

! Specification statements
!     .. Parameters ..

INTEGER, INTENT(IN)   :: md
INTEGER, INTENT(IN)   :: nxd
INTEGER, INTENT(IN)   :: nyd
REAL, INTENT(IN)      :: xd(nxd)
REAL, INTENT(IN)      :: yd(nyd)
REAL, INTENT(IN OUT)  :: zd(nxd,nyd)
INTEGER, INTENT(IN)   :: nxi
REAL, INTENT(IN OUT)  :: xi(nxi)
INTEGER, INTENT(IN)   :: nyi
REAL, INTENT(IN)      :: yi(nyi)
REAL, INTENT(IN OUT)  :: zi(nxi,nyi)
INTEGER, INTENT(OUT)  :: ier

!     ..
!     .. Local Scalars ..
INTEGER, PARAMETER  :: nipimx=51

INTEGER  :: ix, ixi, iy, iyi, nipi
!     ..
!     .. Local Arrays ..
REAL     :: yii(nipimx)
INTEGER  :: inxi(nipimx), inyi(nipimx)

! Allocate workspace
REAL  :: wk(3,nxd,nyd)
!     ..
!     .. External Subroutines ..
! EXTERNAL         rglctn,rgpd3p,rgplnl
!     ..
!     .. Intrinsic Functions ..
! INTRINSIC        MIN
!     ..

! Preliminary processing
! Error check
IF (nxd <= 1) GO TO 60
IF (nyd <= 1) GO TO 70
DO  ix = 2,nxd
  IF (xd(ix) <= xd(ix-1)) GO TO 80
END DO
DO  iy = 2,nyd
  IF (yd(iy) <= yd(iy-1)) GO TO 90
END DO
IF (nxi <= 0) GO TO 100
IF (nyi <= 0) GO TO 110
ier = 0

! Calculation
! Estimates partial derivatives at all input-grid data points
! (for MD=1).
IF (md /= 2) THEN
  CALL rgpd3p(nxd, nyd, xd, yd, zd, wk)
END IF

! Outermost DO-loop with respect to the y coordinate of the output grid points
DO  iyi = 1,nyi
  DO  ixi = 1,nipimx
    yii(ixi) = yi(iyi)
  END DO

! Second DO-loop with respect to the x coordinate of the output grid points
! Processes NIPIMX output-grid points, at most, at a time.
  DO  ixi = 1,nxi,nipimx
    nipi = MIN(nxi- (ixi-1), nipimx)
! Locates the output-grid points.
    CALL rglctn(nxd, nyd, xd, yd, nipi, xi(ixi), yii, inxi, inyi)

! Calculates the z values at the output-grid points.
    CALL rgplnl(nxd, nyd, xd, yd, zd, wk, nipi, xi(ixi), yii, inxi, inyi,  &
                zi(ixi,iyi))
  END DO
END DO
RETURN

! Error exit
60 WRITE (*,FMT=9000)
ier = 1
GO TO 120
70 WRITE (*,FMT=9010)
ier = 2
GO TO 120
80 WRITE (*,FMT=9020) ix,xd(ix)
ier = 3
GO TO 120
90 WRITE (*,FMT=9030) iy,yd(iy)
ier = 4
GO TO 120
100 WRITE (*,FMT=9040)
ier = 5
GO TO 120
110 WRITE (*,FMT=9050)
ier = 6
120 WRITE (*,FMT=9060) nxd,nyd,nxi,nyi
RETURN

! Format statements for error messages
9000 FORMAT (/' *** RGSF3P Error 1: NXD = 1 or less')
9010 FORMAT (/' *** RGSF3P Error 2: NYD = 1 or less')
9020 FORMAT (/' *** RGSF3P Error 3: Identical XD values or',  &
    ' XD values out of sequence',/,'    IX =',i6,',  XD(IX) =', e11.3)
9030 FORMAT (/' *** RGSF3P Error 4: Identical YD values or',  &
    ' YD values out of sequence',/,'    IY =',i6,',  YD(IY) =', e11.3)
9040 FORMAT (/' *** RGSF3P Error 5: NXI = 0 or less')
9050 FORMAT (/' *** RGSF3P Error 6: NYI = 0 or less')
9060 FORMAT ('    NXD =', i5, ',  NYD =', i5, ',  NXI =', i5,',  NYI =', i5 /)
END SUBROUTINE rgsf3p

!     ..
! Statement Function definitions
! z2f(xx1,xx2,zz0,zz1) = (zz1-zz0)*xx2/xx1 + zz0
! z3f(xx1,xx2,xx3,zz0,zz1,zz2) = ((zz2-zz0)* (xx3-xx1)/xx2 -  &
!    (zz1-zz0)* (xx3-xx2)/xx1)* (xx3/ (xx2-xx1)) + zz0

FUNCTION z2f(xx1, xx2, zz0, zz1) RESULT(fn_val)

REAL, INTENT(IN)  :: xx1, xx2, zz0, zz1
REAL              :: fn_val

fn_val = (zz1-zz0)*xx2/xx1 + zz0
RETURN
END FUNCTION z2f

FUNCTION z3f(xx1, xx2, xx3, zz0, zz1, zz2) RESULT(fn_val)

REAL, INTENT(IN)  :: xx1, xx2, xx3, zz0, zz1, zz2
REAL              :: fn_val

fn_val = ((zz2-zz0)*(xx3-xx1)/xx2 - (zz1-zz0)*(xx3-xx2)/xx1) *  &
          (xx3/(xx2-xx1)) + zz0
RETURN
END FUNCTION z3f

SUBROUTINE rgpd3p(nxd, nyd, xd, yd, zd, pdd)

! Partial derivatives of a bivariate function on a rectangular grid
! (a supporting subroutine of the RGBI3P/RGSF3P subroutine package)

! Hiroshi Akima
! U.S. Department of Commerce, NTIA/ITS
! Version of 1995/08

! This subroutine estimates three partial derivatives, zx, zy, and
! zxy, of a bivariate function, z(x,y), on a rectangular grid in
! the x-y plane.  It is based on the revised Akima method that has
! the accuracy of a bicubic polynomial.

! The input arguments are
!   NXD = number of the input-grid data points in the x
!         coordinate (must be 2 or greater),
!   NYD = number of the input-grid data points in the y
!         coordinate (must be 2 or greater),
!   XD  = array of dimension NXD containing the x coordinates of the
!         input-grid data points (must be in a monotonic increasing order),
!   YD  = array of dimension NYD containing the y coordinates of the
!         input-grid data points (must be in a monotonic increasing order),
!   ZD  = two-dimensional array of dimension NXD*NYD
!         containing the z(x,y) values at the input-grid data points.

! The output argument is
!   PDD = three-dimensional array of dimension 3*NXD*NYD,
!         where the estimated zx, zy, and zxy values at the
!         input-grid data points are to be stored.

! Specification statements
!     .. Scalar Arguments ..

INTEGER, INTENT(IN)  :: nxd
INTEGER, INTENT(IN)  :: nyd
REAL, INTENT(IN)     :: xd(nxd)
REAL, INTENT(IN)     :: yd(nyd)
REAL, INTENT(IN)     :: zd(nxd,nyd)
REAL, INTENT(OUT)    :: pdd(3,nxd,nyd)

!     ..
!     .. Local Scalars ..
REAL :: b00, b00x, b00y, b01, b10, b11, cx1, cx2, cx3, cy1, cy2,  &
        cy3, disf, dnm, dz00, dz01, dz02, dz03, dz10, dz11, dz12,  &
        dz13, dz20, dz21, dz22, dz23, dz30, dz31, dz32, dz33,  &
        dzx10, dzx20, dzx30, dzxy11, dzxy12, dzxy13, dzxy21,  &
        dzxy22, dzxy23, dzxy31, dzxy32, dzxy33, dzy01, dzy02,  &
        dzy03, epsln, pezx, pezxy, pezy, smpef, smpei, smwtf,  &
        smwti, sx, sxx, sxxy, sxxyy, sxy, sxyy, sxyz, sxz, sy, syy,  &
        syz, sz, volf, wt, x0, x1, x2, x3, y0, y1, y2,  &
        y3, z00, z01, z02, z03, z10, z11, z12, z13, z20, z21, z22,  &
        z23, z30, z31, z32, z33, zxdi, zxydi, zydi
INTEGER :: ipex, ipey, ix0, ix1, ix2, ix3, iy0, iy1, iy2, iy3, nx0, ny0
!     ..
!     .. Local Arrays ..
REAL    :: b00xa(4), b00ya(4), b01a(4), b10a(4), cxa(3,4), cya(3,4),   &
           sxa(4), sxxa(4), sya(4), syya(4), xa(3,4), ya(3,4),   &
           z0ia(3,4), zi0a(3,4)
! INTEGER :: idlt(3,4)
!     ..
!     .. Intrinsic Functions ..
! INTRINSIC        MAX
!     ..
!     .. Statement Functions ..
! REAL :: z2f,z3f
!     ..
! Data statements
! DATA ((idlt(jxy,jpexy),jpexy=1,4),jxy=1,3)/-3,-2,-1,1,-2,-1,1,2,-1,1,2,3/
INTEGER, SAVE  :: idlt(3,4) = RESHAPE(   &
                  (/ -3,-2,-1, -2,-1,1, -1,1,2, 1,2,3 /), (/ 3, 4 /) )
!     ..

! Calculation
! Initial setting of some local variables
nx0 = MAX(4,nxd)
ny0 = MAX(4,nyd)

! Double DO-loop with respect to the input grid points
DO  iy0 = 1,nyd
  DO  ix0 = 1,nxd
    x0 = xd(ix0)
    y0 = yd(iy0)
    z00 = zd(ix0,iy0)

! Part 1.  Estimation of ZXDI
! Initial setting
    smpef = 0.0
    smwtf = 0.0
    smpei = 0.0
    smwti = 0.0
! DO-loop with respect to the primary estimate
    DO  ipex = 1,4
! Selects necessary grid points in the x direction.
      ix1 = ix0 + idlt(1,ipex)
      ix2 = ix0 + idlt(2,ipex)
      ix3 = ix0 + idlt(3,ipex)
      IF ((ix1 < 1) .OR. (ix2 < 1) .OR. (ix3 < 1) .OR.  &
          (ix1 > nx0) .OR. (ix2 > nx0) .OR. (ix3 > nx0)) CYCLE
! Selects and/or supplements the x and z values.
      x1 = xd(ix1) - x0
      z10 = zd(ix1,iy0)
      IF (nxd >= 4) THEN
        x2 = xd(ix2) - x0
        x3 = xd(ix3) - x0
        z20 = zd(ix2,iy0)
        z30 = zd(ix3,iy0)
      ELSE IF (nxd == 3) THEN
        x2 = xd(ix2) - x0
        z20 = zd(ix2,iy0)
        x3 = 2*xd(3) - xd(2) - x0
        z30 = z3f(x1,x2,x3,z00,z10,z20)
      ELSE IF (nxd == 2) THEN
        x2 = 2*xd(2) - xd(1) - x0
        z20 = z2f(x1,x2,z00,z10)
        x3 = 2*xd(1) - xd(2) - x0
        z30 = z2f(x1,x3,z00,z10)
      END IF
      dzx10 = (z10-z00)/x1
      dzx20 = (z20-z00)/x2
      dzx30 = (z30-z00)/x3
! Calculates the primary estimate of partial derivative zx as
! the coefficient of the bicubic polynomial.
      cx1 = x2*x3/ ((x1-x2)* (x1-x3))
      cx2 = x3*x1/ ((x2-x3)* (x2-x1))
      cx3 = x1*x2/ ((x3-x1)* (x3-x2))
      pezx = cx1*dzx10 + cx2*dzx20 + cx3*dzx30
! Calculates the volatility factor and distance factor in the x
! direction for the primary estimate of zx.
      sx = x1 + x2 + x3
      sz = z00 + z10 + z20 + z30
      sxx = x1*x1 + x2*x2 + x3*x3
      sxz = x1*z10 + x2*z20 + x3*z30
      dnm = 4.0*sxx - sx*sx
      b00 = (sxx*sz-sx*sxz)/dnm
      b10 = (4.0*sxz-sx*sz)/dnm
      dz00 = z00 - b00
      dz10 = z10 - (b00+b10*x1)
      dz20 = z20 - (b00+b10*x2)
      dz30 = z30 - (b00+b10*x3)
      volf = dz00**2 + dz10**2 + dz20**2 + dz30**2
      disf = sxx

! Calculates the EPSLN value, which is used to decide whether or
! not the volatility factor is essentially zero.
      epsln = (z00**2+z10**2+z20**2+z30**2)*1.0E-12
! Accumulates the weighted primary estimates of zx and their weights.
      IF (volf > epsln) THEN
! - For a finite weight.
        wt = 1.0/ (volf*disf)
        smpef = smpef + wt*pezx
        smwtf = smwtf + wt
      ELSE
! - For an infinite weight.
        smpei = smpei + pezx
        smwti = smwti + 1.0
      END IF

! Saves the necessary values for estimating zxy
      xa(1,ipex) = x1
      xa(2,ipex) = x2
      xa(3,ipex) = x3
      zi0a(1,ipex) = z10
      zi0a(2,ipex) = z20
      zi0a(3,ipex) = z30
      cxa(1,ipex) = cx1
      cxa(2,ipex) = cx2
      cxa(3,ipex) = cx3
      sxa(ipex) = sx
      sxxa(ipex) = sxx
      b00xa(ipex) = b00
      b10a(ipex) = b10
    END DO

! Calculates the final estimate of zx.
    IF (smwti < 0.5) THEN
! - When no infinite weights exist.
      zxdi = smpef/smwtf
    ELSE
! - When infinite weights exist.
      zxdi = smpei/smwti
    END IF
! End of Part 1.

! Part 2.  Estimation of ZYDI
! Initial setting
    smpef = 0.0
    smwtf = 0.0
    smpei = 0.0
    smwti = 0.0
! DO-loop with respect to the primary estimate
    DO  ipey = 1,4
! Selects necessary grid points in the y direction.
      iy1 = iy0 + idlt(1,ipey)
      iy2 = iy0 + idlt(2,ipey)
      iy3 = iy0 + idlt(3,ipey)
      IF ((iy1 < 1) .OR. (iy2 < 1) .OR. (iy3 < 1) .OR.  &
          (iy1 > ny0) .OR. (iy2 > ny0) .OR. (iy3 > ny0)) CYCLE
! Selects and/or supplements the y and z values.
      y1 = yd(iy1) - y0
      z01 = zd(ix0,iy1)
      IF (nyd >= 4) THEN
        y2 = yd(iy2) - y0
        y3 = yd(iy3) - y0
        z02 = zd(ix0,iy2)
        z03 = zd(ix0,iy3)
      ELSE IF (nyd == 3) THEN
        y2 = yd(iy2) - y0
        z02 = zd(ix0,iy2)
        y3 = 2*yd(3) - yd(2) - y0
        z03 = z3f(y1,y2,y3,z00,z01,z02)
      ELSE IF (nyd == 2) THEN
        y2 = 2*yd(2) - yd(1) - y0
        z02 = z2f(y1,y2,z00,z01)
        y3 = 2*yd(1) - yd(2) - y0
        z03 = z2f(y1,y3,z00,z01)
      END IF
      dzy01 = (z01-z00)/y1
      dzy02 = (z02-z00)/y2
      dzy03 = (z03-z00)/y3
! Calculates the primary estimate of partial derivative zy as
! the coefficient of the bicubic polynomial.
      cy1 = y2*y3/ ((y1-y2)* (y1-y3))
      cy2 = y3*y1/ ((y2-y3)* (y2-y1))
      cy3 = y1*y2/ ((y3-y1)* (y3-y2))
      pezy = cy1*dzy01 + cy2*dzy02 + cy3*dzy03
! Calculates the volatility factor and distance factor in the y
! direction for the primary estimate of zy.
      sy = y1 + y2 + y3
      sz = z00 + z01 + z02 + z03
      syy = y1*y1 + y2*y2 + y3*y3
      syz = y1*z01 + y2*z02 + y3*z03
      dnm = 4.0*syy - sy*sy
      b00 = (syy*sz-sy*syz)/dnm
      b01 = (4.0*syz-sy*sz)/dnm
      dz00 = z00 - b00
      dz01 = z01 - (b00+b01*y1)
      dz02 = z02 - (b00+b01*y2)
      dz03 = z03 - (b00+b01*y3)
      volf = dz00**2 + dz01**2 + dz02**2 + dz03**2
      disf = syy

! Calculates the EPSLN value, which is used to decide whether or
! not the volatility factor is essentially zero.
      epsln = (z00**2+z01**2+z02**2+z03**2)*1.0E-12
! Accumulates the weighted primary estimates of zy and their weights.
      IF (volf > epsln) THEN
! - For a finite weight.
        wt = 1.0/ (volf*disf)
        smpef = smpef + wt*pezy
        smwtf = smwtf + wt
      ELSE
! - For an infinite weight.
        smpei = smpei + pezy
        smwti = smwti + 1.0
      END IF
! Saves the necessary values for estimating zxy
      ya(1,ipey) = y1
      ya(2,ipey) = y2
      ya(3,ipey) = y3
      z0ia(1,ipey) = z01
      z0ia(2,ipey) = z02
      z0ia(3,ipey) = z03
      cya(1,ipey) = cy1
      cya(2,ipey) = cy2
      cya(3,ipey) = cy3
      sya(ipey) = sy
      syya(ipey) = syy
      b00ya(ipey) = b00
      b01a(ipey) = b01
    END DO

! Calculates the final estimate of zy.
    IF (smwti < 0.5) THEN
! - When no infinite weights exist.
      zydi = smpef/smwtf
    ELSE
! - When infinite weights exist.
      zydi = smpei/smwti
    END IF
! End of Part 2.

! Part 3.  Estimation of ZXYDI
! Initial setting
    smpef = 0.0
    smwtf = 0.0
    smpei = 0.0
    smwti = 0.0
! Outer DO-loops with respect to the primary estimates in the x direction
    DO  ipex = 1,4
      ix1 = ix0 + idlt(1,ipex)
      ix2 = ix0 + idlt(2,ipex)
      ix3 = ix0 + idlt(3,ipex)
      IF ((ix1 < 1) .OR. (ix2 < 1) .OR. (ix3 < 1) .OR.  &
          (ix1 > nx0) .OR. (ix2 > nx0) .OR. (ix3 > nx0)) CYCLE
! Retrieves the necessary values for estimating zxy in the x direction.
      x1 = xa(1,ipex)
      x2 = xa(2,ipex)
      x3 = xa(3,ipex)
      z10 = zi0a(1,ipex)
      z20 = zi0a(2,ipex)
      z30 = zi0a(3,ipex)
      cx1 = cxa(1,ipex)
      cx2 = cxa(2,ipex)
      cx3 = cxa(3,ipex)
      sx = sxa(ipex)
      sxx = sxxa(ipex)
      b00x = b00xa(ipex)
      b10 = b10a(ipex)

! Inner DO-loops with respect to the primary estimates in the y direction
      DO  ipey = 1,4
        iy1 = iy0 + idlt(1,ipey)
        iy2 = iy0 + idlt(2,ipey)
        iy3 = iy0 + idlt(3,ipey)
        IF ((iy1 < 1) .OR. (iy2 < 1) .OR. (iy3 < 1) .OR. (iy1 > ny0) .OR.  &
            (iy2 > ny0) .OR. (iy3 > ny0)) CYCLE
! Retrieves the necessary values for estimating zxy in the y direction.
        y1 = ya(1,ipey)
        y2 = ya(2,ipey)
        y3 = ya(3,ipey)
        z01 = z0ia(1,ipey)
        z02 = z0ia(2,ipey)
        z03 = z0ia(3,ipey)
        cy1 = cya(1,ipey)
        cy2 = cya(2,ipey)
        cy3 = cya(3,ipey)
        sy = sya(ipey)
        syy = syya(ipey)
        b00y = b00ya(ipey)
        b01 = b01a(ipey)
! Selects and/or supplements the z values.
        IF (nyd >= 4) THEN
          z11 = zd(ix1,iy1)
          z12 = zd(ix1,iy2)
          z13 = zd(ix1,iy3)
          IF (nxd >= 4) THEN
            z21 = zd(ix2,iy1)
            z22 = zd(ix2,iy2)
            z23 = zd(ix2,iy3)
            z31 = zd(ix3,iy1)
            z32 = zd(ix3,iy2)
            z33 = zd(ix3,iy3)
          ELSE IF (nxd == 3) THEN
            z21 = zd(ix2,iy1)
            z22 = zd(ix2,iy2)
            z23 = zd(ix2,iy3)
            z31 = z3f(x1,x2,x3,z01,z11,z21)
            z32 = z3f(x1,x2,x3,z02,z12,z22)
            z33 = z3f(x1,x2,x3,z03,z13,z23)
          ELSE IF (nxd == 2) THEN
            z21 = z2f(x1,x2,z01,z11)
            z22 = z2f(x1,x2,z02,z12)
            z23 = z2f(x1,x2,z03,z13)
            z31 = z2f(x1,x3,z01,z11)
            z32 = z2f(x1,x3,z02,z12)
            z33 = z2f(x1,x3,z03,z13)
          END IF
        ELSE IF (nyd == 3) THEN
          z11 = zd(ix1,iy1)
          z12 = zd(ix1,iy2)
          z13 = z3f(y1,y2,y3,z10,z11,z12)
          IF (nxd >= 4) THEN
            z21 = zd(ix2,iy1)
            z22 = zd(ix2,iy2)
            z31 = zd(ix3,iy1)
            z32 = zd(ix3,iy2)
          ELSE IF (nxd == 3) THEN
            z21 = zd(ix2,iy1)
            z22 = zd(ix2,iy2)
            z31 = z3f(x1,x2,x3,z01,z11,z21)
            z32 = z3f(x1,x2,x3,z02,z12,z22)
          ELSE IF (nxd == 2) THEN
            z21 = z2f(x1,x2,z01,z11)
            z22 = z2f(x1,x2,z02,z12)
            z31 = z2f(x1,x3,z01,z11)
            z32 = z2f(x1,x3,z02,z12)
          END IF
          z23 = z3f(y1,y2,y3,z20,z21,z22)
          z33 = z3f(y1,y2,y3,z30,z31,z32)
        ELSE IF (nyd == 2) THEN
          z11 = zd(ix1,iy1)
          z12 = z2f(y1,y2,z10,z11)
          z13 = z2f(y1,y3,z10,z11)
          IF (nxd >= 4) THEN
            z21 = zd(ix2,iy1)
            z31 = zd(ix3,iy1)
          ELSE IF (nxd == 3) THEN
            z21 = zd(ix2,iy1)
            z31 = z3f(x1,x2,x3,z01,z11,z21)
          ELSE IF (nxd == 2) THEN
            z21 = z2f(x1,x2,z01,z11)
            z31 = z2f(x1,x3,z01,z11)
          END IF
          z22 = z2f(y1,y2,z20,z21)
          z23 = z2f(y1,y3,z20,z21)
          z32 = z2f(y1,y2,z30,z31)
          z33 = z2f(y1,y3,z30,z31)
        END IF
! Calculates the primary estimate of partial derivative zxy as
! the coefficient of the bicubic polynomial.
        dzxy11 = (z11-z10-z01+z00)/ (x1*y1)
        dzxy12 = (z12-z10-z02+z00)/ (x1*y2)
        dzxy13 = (z13-z10-z03+z00)/ (x1*y3)
        dzxy21 = (z21-z20-z01+z00)/ (x2*y1)
        dzxy22 = (z22-z20-z02+z00)/ (x2*y2)
        dzxy23 = (z23-z20-z03+z00)/ (x2*y3)
        dzxy31 = (z31-z30-z01+z00)/ (x3*y1)
        dzxy32 = (z32-z30-z02+z00)/ (x3*y2)
        dzxy33 = (z33-z30-z03+z00)/ (x3*y3)
        pezxy = cx1* (cy1*dzxy11+cy2*dzxy12+cy3*dzxy13) +  &
                cx2* (cy1*dzxy21+cy2*dzxy22+cy3*dzxy23) +  &
                cx3* (cy1*dzxy31+cy2*dzxy32+cy3*dzxy33)
! Calculates the volatility factor and distance factor in the x
! and y directions for the primary estimate of zxy.
        b00 = (b00x+b00y)/2.0
        sxy = sx*sy
        sxxy = sxx*sy
        sxyy = sx*syy
        sxxyy = sxx*syy
        sxyz = x1* (y1*z11+y2*z12+y3*z13) + x2* (y1*z21+y2*z22+y3*z23) +  &
               x3* (y1*z31+y2*z32+y3*z33)
        b11 = (sxyz-b00*sxy-b10*sxxy-b01*sxyy)/sxxyy
        dz00 = z00 - b00
        dz01 = z01 - (b00+b01*y1)
        dz02 = z02 - (b00+b01*y2)
        dz03 = z03 - (b00+b01*y3)
        dz10 = z10 - (b00+b10*x1)
        dz11 = z11 - (b00+b01*y1+x1* (b10+b11*y1))
        dz12 = z12 - (b00+b01*y2+x1* (b10+b11*y2))
        dz13 = z13 - (b00+b01*y3+x1* (b10+b11*y3))
        dz20 = z20 - (b00+b10*x2)
        dz21 = z21 - (b00+b01*y1+x2* (b10+b11*y1))
        dz22 = z22 - (b00+b01*y2+x2* (b10+b11*y2))
        dz23 = z23 - (b00+b01*y3+x2* (b10+b11*y3))
        dz30 = z30 - (b00+b10*x3)
        dz31 = z31 - (b00+b01*y1+x3* (b10+b11*y1))
        dz32 = z32 - (b00+b01*y2+x3* (b10+b11*y2))
        dz33 = z33 - (b00+b01*y3+x3* (b10+b11*y3))
        volf = dz00**2 + dz01**2 + dz02**2 + dz03**2 +  &
            dz10**2 + dz11**2 + dz12**2 + dz13**2 +  &
            dz20**2 + dz21**2 + dz22**2 + dz23**2 +  &
            dz30**2 + dz31**2 + dz32**2 + dz33**2
        disf = sxx*syy
! Calculates EPSLN.
        epsln = (z00**2 + z01**2 + z02**2 + z03**2 + z10**2 +   &
                z11**2 + z12**2 + z13**2 + z20**2 + z21**2 + z22**2 +   &
                z23**2 + z30**2 + z31**2 + z32**2 + z33**2)* 1.0E-12
! Accumulates the weighted primary estimates of zxy and their weights.
        IF (volf > epsln) THEN
! - For a finite weight.
          wt = 1.0/ (volf*disf)
          smpef = smpef + wt*pezxy
          smwtf = smwtf + wt
        ELSE
! - For an infinite weight.
          smpei = smpei + pezxy
          smwti = smwti + 1.0
        END IF
      END DO
    END DO

! Calculates the final estimate of zxy.
    IF (smwti < 0.5) THEN
! - When no infinite weights exist.
      zxydi = smpef/smwtf
    ELSE
! - When infinite weights exist.
      zxydi = smpei/smwti
    END IF
! End of Part 3

    pdd(1,ix0,iy0) = zxdi
    pdd(2,ix0,iy0) = zydi
    pdd(3,ix0,iy0) = zxydi
  END DO
END DO
RETURN
END SUBROUTINE rgpd3p

SUBROUTINE rglctn(nxd, nyd, xd, yd, nip, xi, yi, inxi, inyi)

! Location of the desired points in a rectangular grid
! (a supporting subroutine of the RGBI3P/RGSF3P subroutine package)

! Hiroshi Akima
! U.S. Department of Commerce, NTIA/ITS
! Version of 1995/08

! This subroutine locates the desired points in a rectangular grid
! in the x-y plane.

! The grid lines can be unevenly spaced.

! The input arguments are
!   NXD  = number of the input-grid data points in the x
!          coordinate (must be 2 or greater),
!   NYD  = number of the input-grid data points in the y
!          coordinate (must be 2 or greater),
!   XD   = array of dimension NXD containing the x coordinates of the
!          input-grid data points (must be in a monotonic increasing order),
!   YD   = array of dimension NYD containing the y coordinates of the
!          input-grid data points (must be in a monotonic increasing order),
!   NIP  = number of the output points to be located (must be 1 or greater),
!   XI   = array of dimension NIP containing the x coordinates
!          of the output points to be located,
!   YI   = array of dimension NIP containing the y coordinates
!          of the output points to be located.

! The output arguments are
!   INXI = integer array of dimension NIP where the interval
!          numbers of the XI array elements are to be stored,
!   INYI = integer array of dimension NIP where the interval
!          numbers of the YI array elements are to be stored.
! The interval numbers are between 0 and NXD and between 0 and NYD,
! respectively.

! Specification statements
!     .. Scalar Arguments ..

INTEGER, INTENT(IN)   :: nxd
INTEGER, INTENT(IN)   :: nyd
REAL, INTENT(IN)      :: xd(nxd)
REAL, INTENT(IN)      :: yd(nyd)
INTEGER, INTENT(IN)   :: nip
REAL, INTENT(IN)      :: xi(nip)
REAL, INTENT(IN)      :: yi(nip)
INTEGER, INTENT(OUT)  :: inxi(nip)
INTEGER, INTENT(OUT)  :: inyi(nip)

!     ..
!     .. Local Scalars ..
REAL     :: xii, yii
INTEGER  :: iip, imd, imn, imx, ixd, iyd, nintx, ninty

!     ..
! DO-loop with respect to IIP, which is the point number of the output point
DO  iip = 1,nip
  xii = xi(iip)
  yii = yi(iip)
! Checks if the x coordinate of the IIPth output point, XII, is
! in a new interval.  (NINTX is the new-interval flag.)
  IF (iip == 1) THEN
    nintx = 1
  ELSE
    nintx = 0
    IF (ixd == 0) THEN
      IF (xii > xd(1)) nintx = 1
    ELSE IF (ixd < nxd) THEN
      IF ((xii < xd(ixd)) .OR. (xii > xd(ixd+1))) nintx = 1
    ELSE
      IF (xii < xd(nxd)) nintx = 1
    END IF
  END IF

! Locates the output point by binary search if XII is in a new interval.
! Determines IXD for which XII lies between XD(IXD) and XD(IXD+1).
  IF (nintx == 1) THEN
    IF (xii <= xd(1)) THEN
      ixd = 0
    ELSE IF (xii < xd(nxd)) THEN
      imn = 1
      imx = nxd
      imd = (imn+imx)/2
      10 IF (xii >= xd(imd)) THEN
        imn = imd
      ELSE
        imx = imd
      END IF
      imd = (imn+imx)/2
      IF (imd > imn) GO TO 10
      ixd = imd
    ELSE
      ixd = nxd
    END IF
  END IF
  inxi(iip) = ixd

! Checks if the y coordinate of the IIPth output point, YII, is
! in a new interval.  (NINTY is the new-interval flag.)
  IF (iip == 1) THEN
    ninty = 1
  ELSE
    ninty = 0
    IF (iyd == 0) THEN
      IF (yii > yd(1)) ninty = 1
    ELSE IF (iyd < nyd) THEN
      IF ((yii < yd(iyd)) .OR. (yii > yd(iyd+1))) ninty = 1
    ELSE
      IF (yii < yd(nyd)) ninty = 1
    END IF
  END IF

! Locates the output point by binary search if YII is in a new interval.
! Determines IYD for which YII lies between YD(IYD) and YD(IYD+1).
  IF (ninty == 1) THEN
    IF (yii <= yd(1)) THEN
      iyd = 0
    ELSE IF (yii < yd(nyd)) THEN
      imn = 1
      imx = nyd
      imd = (imn+imx)/2
      20 IF (yii >= yd(imd)) THEN
        imn = imd
      ELSE
        imx = imd
      END IF
      imd = (imn+imx)/2
      IF (imd > imn) GO TO 20
      iyd = imd
    ELSE
      iyd = nyd
    END IF
  END IF
  inyi(iip) = iyd
END DO
RETURN
END SUBROUTINE rglctn

SUBROUTINE rgplnl(nxd, nyd, xd, yd, zd, pdd, nip, xi, yi, inxi, inyi, zi)

! Polynomials for rectangular-grid bivariate interpolation and surface fitting
! (a supporting subroutine of the RGBI3P/RGSF3P subroutine package)

! Hiroshi Akima
! U.S. Department of Commerce, NTIA/ITS
! Version of 1995/08

! This subroutine determines a polynomial in x and y for a rectangle of the
! input grid in the x-y plane and calculates the z value for the desired
! points by evaluating the polynomial for rectangular-grid bivariate
! interpolation and surface fitting.

! The input arguments are
!   NXD  = number of the input-grid data points in the x
!          coordinate (must be 2 or greater),
!   NYD  = number of the input-grid data points in the y
!          coordinate (must be 2 or greater),
!   XD   = array of dimension NXD containing the x coordinates of the
!          input-grid data points (must be in a monotonic increasing order),
!   YD   = array of dimension NYD containing the y coordinates of the
!          input-grid data points (must be in a monotonic increasing order),
!   ZD   = two-dimensional array of dimension NXD*NYD
!          containing the z(x,y) values at the input-grid data points,
!   PDD  = three-dimensional array of dimension 3*NXD*NYD
!          containing the estimated zx, zy, and zxy values
!          at the input-grid data points,
!   NIP  = number of the output points at which interpolation
!          is to be performed,
!   XI   = array of dimension NIP containing the x coordinates
!          of the output points,
!   YI   = array of dimension NIP containing the y coordinates
!          of the output points,
!   INXI = integer array of dimension NIP containing the
!          interval numbers of the input grid intervals in the
!          x direction where the x coordinates of the output points lie,
!   INYI = integer array of dimension NIP containing the
!          interval numbers of the input grid intervals in the
!          y direction where the y coordinates of the output points lie.

! The output argument is
!   ZI   = array of dimension NIP, where the interpolated z
!          values at the output points are to be stored.

! Specification statements
!     .. Scalar Arguments ..

INTEGER, INTENT(IN)  :: nxd
INTEGER, INTENT(IN)  :: nyd
REAL, INTENT(IN)     :: xd(nxd)
REAL, INTENT(IN)     :: yd(nyd)
REAL, INTENT(IN)     :: zd(nxd,nyd)
REAL, INTENT(IN)     :: pdd(3,nxd,nyd)
INTEGER, INTENT(IN)  :: nip
REAL, INTENT(IN)     :: xi(nip)
REAL, INTENT(IN)     :: yi(nip)
INTEGER, INTENT(IN)  :: inxi(nip)
INTEGER, INTENT(IN)  :: inyi(nip)
REAL, INTENT(OUT)    :: zi(nip)

!     ..
!     .. Local Scalars ..
REAL :: a, b, c, d, dx, dxsq, dy, dysq, p00, p01, p02, p03, p10, p11,  &
        p12, p13, p20, p21, p22, p23, p30, p31, p32, p33, q0, q1, q2,  &
        q3, u, v, x0, xii, y0, yii, z00, z01, z0dx, z0dy, z10, z11,  &
        z1dx, z1dy, zdxdy, zii, zx00, zx01, zx0dy, zx10, zx11,  &
        zx1dy, zxy00, zxy01, zxy10, zxy11, zy00, zy01, zy0dx, zy10, zy11, zy1dx
INTEGER :: iip, ixd0, ixd1, ixdi, ixdipv, iyd0, iyd1, iydi, iydipv
!     ..
!     .. Intrinsic Functions ..
! INTRINSIC        MAX
!     ..

! Calculation
! Outermost DO-loop with respect to the output point
DO  iip = 1,nip
  xii = xi(iip)
  yii = yi(iip)
  IF (iip == 1) THEN
    ixdipv = -1
    iydipv = -1
  ELSE
    ixdipv = ixdi
    iydipv = iydi
  END IF
  ixdi = inxi(iip)
  iydi = inyi(iip)

! Retrieves the z and partial derivative values at the origin of
! the coordinate for the rectangle.
  IF (ixdi /= ixdipv .OR. iydi /= iydipv) THEN
    ixd0 = MAX(1,ixdi)
    iyd0 = MAX(1,iydi)
    x0 = xd(ixd0)
    y0 = yd(iyd0)
    z00 = zd(ixd0,iyd0)
    zx00 = pdd(1,ixd0,iyd0)
    zy00 = pdd(2,ixd0,iyd0)
    zxy00 = pdd(3,ixd0,iyd0)
  END IF

! Case 1.  When the rectangle is inside the data area in both the
! x and y directions.
  IF ((ixdi > 0 .AND. ixdi < nxd) .AND. (iydi > 0 .AND. iydi < nyd)) THEN
! Retrieves the z and partial derivative values at the other three
! vertices of the rectangle.
    IF (ixdi /= ixdipv .OR. iydi /= iydipv) THEN
      ixd1 = ixd0 + 1
      dx = xd(ixd1) - x0
      dxsq = dx*dx
      iyd1 = iyd0 + 1
      dy = yd(iyd1) - y0
      dysq = dy*dy
      z10 = zd(ixd1,iyd0)
      z01 = zd(ixd0,iyd1)
      z11 = zd(ixd1,iyd1)
      zx10 = pdd(1,ixd1,iyd0)
      zx01 = pdd(1,ixd0,iyd1)
      zx11 = pdd(1,ixd1,iyd1)
      zy10 = pdd(2,ixd1,iyd0)
      zy01 = pdd(2,ixd0,iyd1)
      zy11 = pdd(2,ixd1,iyd1)
      zxy10 = pdd(3,ixd1,iyd0)
      zxy01 = pdd(3,ixd0,iyd1)
      zxy11 = pdd(3,ixd1,iyd1)
! Calculates the polynomial coefficients.
      z0dx = (z10-z00)/dx
      z1dx = (z11-z01)/dx
      z0dy = (z01-z00)/dy
      z1dy = (z11-z10)/dy
      zx0dy = (zx01-zx00)/dy
      zx1dy = (zx11-zx10)/dy
      zy0dx = (zy10-zy00)/dx
      zy1dx = (zy11-zy01)/dx
      zdxdy = (z1dy-z0dy)/dx
      a = zdxdy - zx0dy - zy0dx + zxy00
      b = zx1dy - zx0dy - zxy10 + zxy00
      c = zy1dx - zy0dx - zxy01 + zxy00
      d = zxy11 - zxy10 - zxy01 + zxy00
      p00 = z00
      p01 = zy00
      p02 = (2.0* (z0dy-zy00)+z0dy-zy01)/dy
      p03 = (-2.0*z0dy+zy01+zy00)/dysq
      p10 = zx00
      p11 = zxy00
      p12 = (2.0* (zx0dy-zxy00)+zx0dy-zxy01)/dy
      p13 = (-2.0*zx0dy+zxy01+zxy00)/dysq
      p20 = (2.0* (z0dx-zx00)+z0dx-zx10)/dx
      p21 = (2.0* (zy0dx-zxy00)+zy0dx-zxy10)/dx
      p22 = (3.0* (3.0*a-b-c)+d)/ (dx*dy)
      p23 = (-6.0*a+2.0*b+3.0*c-d)/ (dx*dysq)
      p30 = (-2.0*z0dx+zx10+zx00)/dxsq
      p31 = (-2.0*zy0dx+zxy10+zxy00)/dxsq
      p32 = (-6.0*a+3.0*b+2.0*c-d)/ (dxsq*dy)
      p33 = (2.0* (2.0*a-b-c)+d)/ (dxsq*dysq)
    END IF

! Evaluates the polynomial.
    u = xii - x0
    v = yii - y0
    q0 = p00 + v* (p01+v* (p02+v*p03))
    q1 = p10 + v* (p11+v* (p12+v*p13))
    q2 = p20 + v* (p21+v* (p22+v*p23))
    q3 = p30 + v* (p31+v* (p32+v*p33))
    zii = q0 + u* (q1+u* (q2+u*q3))
! End of Case 1

! Case 2.  When the rectangle is inside the data area in the x
! direction but outside in the y direction.
  ELSE IF ((ixdi > 0.AND.ixdi < nxd) .AND.  &
        (iydi <= 0.OR.iydi >= nyd)) THEN
! Retrieves the z and partial derivative values at the other
! vertex of the semi-infinite rectangle.
    IF (ixdi /= ixdipv .OR. iydi /= iydipv) THEN
      ixd1 = ixd0 + 1
      dx = xd(ixd1) - x0
      dxsq = dx*dx
      z10 = zd(ixd1,iyd0)
      zx10 = pdd(1,ixd1,iyd0)
      zy10 = pdd(2,ixd1,iyd0)
      zxy10 = pdd(3,ixd1,iyd0)
! Calculates the polynomial coefficients.
      z0dx = (z10-z00)/dx
      zy0dx = (zy10-zy00)/dx
      p00 = z00
      p01 = zy00
      p10 = zx00
      p11 = zxy00
      p20 = (2.0* (z0dx-zx00)+z0dx-zx10)/dx
      p21 = (2.0* (zy0dx-zxy00)+zy0dx-zxy10)/dx
      p30 = (-2.0*z0dx+zx10+zx00)/dxsq
      p31 = (-2.0*zy0dx+zxy10+zxy00)/dxsq
    END IF
! Evaluates the polynomial.
    u = xii - x0
    v = yii - y0
    q0 = p00 + v*p01
    q1 = p10 + v*p11
    q2 = p20 + v*p21
    q3 = p30 + v*p31
    zii = q0 + u* (q1+u* (q2+u*q3))
! End of Case 2

! Case 3.  When the rectangle is outside the data area in the x
! direction but inside in the y direction.
  ELSE IF ((ixdi <= 0.OR.ixdi >= nxd) .AND.  &
        (iydi > 0 .AND. iydi < nyd)) THEN
! Retrieves the z and partial derivative values at the other
! vertex of the semi-infinite rectangle.
    IF (ixdi /= ixdipv .OR. iydi /= iydipv) THEN
      iyd1 = iyd0 + 1
      dy = yd(iyd1) - y0
      dysq = dy*dy
      z01 = zd(ixd0,iyd1)
      zx01 = pdd(1,ixd0,iyd1)
      zy01 = pdd(2,ixd0,iyd1)
      zxy01 = pdd(3,ixd0,iyd1)
! Calculates the polynomial coefficients.
      z0dy = (z01-z00)/dy
      zx0dy = (zx01-zx00)/dy
      p00 = z00
      p01 = zy00
      p02 = (2.0*(z0dy-zy00)+z0dy-zy01)/dy
      p03 = (-2.0*z0dy+zy01+zy00)/dysq
      p10 = zx00
      p11 = zxy00
      p12 = (2.0*(zx0dy-zxy00) + zx0dy - zxy01)/dy
      p13 = (-2.0*zx0dy + zxy01 + zxy00)/dysq
    END IF

! Evaluates the polynomial.
    u = xii - x0
    v = yii - y0
    q0 = p00 + v* (p01 + v*(p02+v*p03))
    q1 = p10 + v* (p11 + v*(p12+v*p13))
    zii = q0 + u*q1
! End of Case 3

! Case 4.  When the rectangle is outside the data area in both the
! x and y direction.
  ELSE IF ((ixdi <= 0 .OR. ixdi >= nxd) .AND.  &
           (iydi <= 0 .OR. iydi >= nyd)) THEN
! Calculates the polynomial coefficients.
    IF (ixdi /= ixdipv .OR. iydi /= iydipv) THEN
      p00 = z00
      p01 = zy00
      p10 = zx00
      p11 = zxy00
    END IF
! Evaluates the polynomial.
    u = xii - x0
    v = yii - y0
    q0 = p00 + v*p01
    q1 = p10 + v*p11
    zii = q0 + u*q1
  END IF
! End of Case 4
  zi(iip) = zii
END DO

RETURN
END SUBROUTINE rgplnl

END MODULE Grid_Interpolation


c
      subroutine cinterp(r,f,nr,rs,ps,dps,work)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c----- this routine interpolates functn f on grid r
c      returns value ps and its derivative dps
c
      implicit real*8 (a-h,o-z)
      logical deriv
      real*8 r(nr),c(4),work(nr),psr,psi,dpsr,dpsi
      complex*16 f(nr),ps,dps
c
      ip1=2
      do i=ip1,nr-1
      if (rs.gt.r(i)) ip1=i+1
      enddo

c Real part
      do i=1,nr
	work(i)=dreal(f(i))
      enddo
      i=ip1-1
      call fit(r,work,nr,i,c)
c
      h1=rs-r(i)
      h2=r(ip1)-rs
      c2=1.d0+c(4)*h1*h2
      psr=((c(3)-c(2))*h1+c(1))/c2
      dpsr=c(2)+(c(3)-c(2)+psr*c(4)*(h1-h2))/c2
      psr=psr+dreal(f(i))-c(1)+c(2)*h1

c Imaginary part
      do i=1,nr
	work(i)=dimag(f(i))
      enddo
      i=ip1-1
      call fit(r,work,nr,i,c)
c
      h1=rs-r(i)
      h2=r(ip1)-rs
      c2=1.d0+c(4)*h1*h2
      psi=((c(3)-c(2))*h1+c(1))/c2
      dpsi=c(2)+(c(3)-c(2)+psi*c(4)*(h1-h2))/c2
      psi=psi+dimag(f(i))-c(1)+c(2)*h1

      ps=dcmplx(psr,psi)
      dps=dcmplx(dpsr,dpsi)

      return
      end


	REAL*4 FUNCTION
     . TSAMPLESIZE(XITYPE,XALPHA,POWER,XDIFF,SIGMA,XM)
	USE MSIMSL
C
C-Description-----------------------------------------------------------
	IMPLICIT NONE
C
C  Function:
C	Main routine of program to compute sample size calculations
C	involving t tests.
C
C  Input prompted for from user:
C	PAIRED or INDEPENDENT study type
C	ALPHA	Type I error probability (two tailed)
C	POWER	The desired statistical power
C	XDIFF    A XDIFFerence in population means
C	SIGMA	An estimate of the within group standard deviation for
C		independent tests.  It is an estimate of the standard
C		deviation of paired response XDIFFerences for paired data.
C	M	the number of control patients per experimental patient.
C		M is only defined for independent t-tests.
C
C  Output:
C	TSAMPLESIZE
C		Sample size needed to detect a true XDIFFerence in
C		population means with type I error probability ALPHA and
C		power POWER.  N=number of pairs of patients needed for
C		paired designs or number of expermental patients needed for
C		independent designs.  That is, independent designs will
C		have N case patients and M*N control patients.
C
C  Notes:
C   .	This routine was written by Dale Plummer
C   .	This program uses sample size formulas that are given in Dupont
C	and Plummer (???).  The	resulting sample size equations are solved
C	iteratively using the secant method.
C
C	Specifically, the case sample size N returned by this program
C	is the solution to the equation
C
C	N=(TCRVALUE(ALPH/2.,N-1)+TCRVALUE(XBETA,N-1))**2/DELTA**2
C	for paired designs or
C
C	N=(TCRVALUE(ALPH/2.,N*(M+1)-2) + TCRVALUE(XBETA,N*(M+1)-2))**2/DELTA**2
C	for independent designs
C
C	where TCRVALUE(P,J) returns the critical value that is exceeded
C	by a t statistic with J degrees of freedom with probability P,
C	and DELTA is a XDIFFerence in means measured in standard deviations.
C	For paired designs DELTA=XDIFF/SIGMA.  For indepedent designs
C	DELTA=XDIFF/(SIGMA*SQRT(1.+1./M)
C
C	The resulting sample size calculations produced by this program
C	are in close agreement with those obtained from Table 10 of
C	Pearson and Hartley, Biometrika Tables for Statisticians, Vol I,
C	3rd Ed., Cambridge:  Cambridge U. Press, 1970.
C
C-Declarations----------------------------------------------------------
C
C
C  Arguments
C
	REAL*4 XALPHA,POWER,XDIFF,SIGMA,XM
	INTEGER*4 XITYPE
C
C  Functions
C
C	REAL TCRVALUE
	REAL TSIZE,ZCRVALUE
	EXTERNAL TSIZE
C
C  Common used to pass needed values to passed name functions.
C
	INTEGER ITYPE
	REAL ALPHA, XBETA, DELTA, M, NU
	COMMON /TSSCOMM/ ALPHA, XBETA, DELTA, M, NU, ITYPE

	REAL EPS, ERRABS, ERRREL, ETA, XGUESS(1), XVECT(1)
	INTEGER ITMAX, NROOT, INFO(1)

	INTEGER DFRESET
	COMMON /DFRESET/ DFRESET
C
C-Code------------------------------------------------------------------
C
C    Copy data to local/common variables as appropriate.
C
	ALPHA=XALPHA
	ITYPE=XITYPE
	M=XM
	XBETA=1.-POWER
C
C    Set delta depending on whether the model is paired or independent.
C
	IF (ITYPE.EQ.1) THEN
C
C    Paired
C    ' Enter ALPHA, POWER, XDIFF and SIGMA:  '
C
	    DELTA=XDIFF/SIGMA
	ELSE IF (ITYPE.EQ.2) THEN
C
C    Independent
C    ' Enter ALPHA, POWER, XDIFF, SIGMA, and M:  '
C
	    DELTA=XDIFF/(SIGMA*SQRT(1.+1./M))
	ELSE
	    TSAMPLESIZE=-999
		RETURN
	END IF
C
C    Solve for sample size.  Note that NU is calculated in the
C    TSIZE routine.
C
C
C    ERRABS - First stopping criterion.  A zero X(I) is accepted if ABS(F(X(I)).LT. ERRABS.
C
C	ERRABS=1.0E-5
	ERRABS=1.0E-4

C
C    EPS - See ETA.
C
C	EPS=1.0E-5
	EPS=1.0E-4
C
C    ERRREL - Second stopping criterion is the relative error.  A zero X(I) is
C    accepted if the relative change of two successive approximations
C    to X(I) is less than ERRREL.
C
C	ERRREL=1.0E-5
	ERRREL=1.0E-4
C
C    ETA - Spread criteria for multiple zeros.  If the zero X(I) has been computed
C    and ABS(X(I) - X(J)).LT.EPS, where X(J) is a previously computed zero,
C    then the computation is restarted with a guess equal to X(I) + ETA.
C
	ETA=1.0E-2
C
C    ITMAX - The maximum allowable number of iterations per zero.
C
	ITMAX=100
C
C    NROOT - The number of zeros to be found by ZREAL.
C
	NROOT=1
C
C    XGUESS - A vector of length NROOT.  XGUESS contains the initial guesses
C    for the zeros.
C
	XGUESS(1)=(ZCRVALUE(ALPHA/2.)+ZCRVALUE(XBETA))**2./(DELTA**2)
C
C    In TSIZE the degrees of freedom can be manipulated.  DFRESET will be
C    set to one if that happens.  Initialize it to zero here.  See TSIZE
C    for details.
C
	DFRESET=0
C
C    Find the zero of the function TSIZE.  When TSIZE is zero XVECT(1) is the
C    sample size needed to detect a true difference DELTA with power 1-BETA
C    and Type I error probability ALPHA.
C
C    XVECT - A vector of length NROOT.  XVECT contains the computed zeros.
C    INFO - An integer vector of length NROOT.  INFO(J) contains the number of
C    iterations used in finding the J-th zero when convergence was achieved.
C    If convergence was not obtained in ITMAX iterations, INFO(J) will be
C    greater than ITMAX.
C
	CALL ZREAL
     .	(TSIZE,ERRABS,ERRREL,EPS,ETA,NROOT,ITMAX,XGUESS,XVECT,INFO)
C
C    If convergence was not reached then INFO(1) will be greater than
C    ITMAX.  Check for that here.
C
	IF (INFO(1).GT.ITMAX) THEN
	    TSAMPLESIZE=-999
		RETURN
	END IF
C
C    Otherwise convergence was reached.  Record the resultant sample size.
C
	TSAMPLESIZE=XVECT(1)
C
C    If conditions warrent then output the disclaimer.  Do loop through
C    6 and 7 to write to both terminal and log file.
C
CCC	    TALPHA=TCRVALUE(ALPHA/2.,NU)
CCC	    TXBETA=TCRVALUE(XBETA/2.,NU)
CCC	    IF (2.*TALPHA+TXBETA .LE. 3.1) THEN
CCC		   CALL HLPMSG(IUNIT,7)
CCC		   WRITE(UNIT=IUNIT,FMT='(5X,A,I6,A,F12.4,A,/,5X,A,F12.4,A,/)')
CCC     .' associated with N=',N,' will be no less than ',1.-XBETA,' and',
CCC     .' no greater than ',1.-XBETA+ALPHA/2.,'.'
CCC	    END IF
	RETURN
	END


module solver_class

  type solver
     integer::Bodies
     real(8),dimension(10) :: mass
     real(8),dimension(10,3) :: position
     real(8),dimension(10,3) :: velocity
  contains
    procedure ::relative_position
    procedure ::forces
    procedure ::calc_position
    procedure ::calc_velocities
    procedure ::kinetic_energy
    procedure ::potential_energy
    procedure ::angular_momentum

 end type solver

contains
  subroutine relative_position(system,numbodies,relposition)
    implicit none

    class (solver),intent(in)::system
    integer :: i,j
    integer,intent(in)::NumBodies
    real(8),dimension(Numbodies,Numbodies,4):: relposition

    do i=1,NumBodies
       do j =1,NumBodies
          if (i.ne.j) then
             relposition(j,i,1)=system%position(j,1)-system%position(i,1)
             relposition(j,i,2)=system%position(j,2)-system%position(i,2)
             relposition(j,i,3)=system%position(j,3)-system%position(i,3)
             relposition(j,i,4)=sqrt(relposition(j,i,1)*relposition(j,i,1)+relposition(j,i,2)*relposition(j,i,2)+relposition(j,i,3)*relposition(j,i,3))
          end if
       end do
    end do

    return
  end subroutine relative_position

  subroutine forces(system,Numbodies,relposition,relforce)
    implicit none

    class(solver),intent(in)::system
    integer :: j,i
    integer,intent(in):: Numbodies
    real(8),dimension(Numbodies,3)::relforce
    real(8),dimension(Numbodies,Numbodies,4):: relposition
    real(8)::rrr,Fourpi2
    Fourpi2 = 4.d0*3.14*3.14

    do i=1,numbodies
       do j=1,numbodies
          relforce(i,j)=0.d0
       end do
    end do

    do i=1,numbodies
       do j=1,numbodies
          if(j.ne.i) then
             rrr=(relposition(j,i,4)**3.d0)
             relforce(i,1) =relforce(i,1) - Fourpi2*system%mass(j)*relposition(j,i,1)/rrr
             relforce(i,2) =relforce(i,2) - Fourpi2*system%mass(j)*relposition(j,i,2)/rrr
             relforce(i,3) =relforce(i,3) - Fourpi2*system%mass(j)*relposition(j,i,3)/rrr
          end if
       end do
    end do
  end subroutine forces

  subroutine calc_position(system,Numbodies,relforce,h)
    implicit none
    class(solver), intent(inout)::system
    integer,intent(in)::Numbodies
    integer::i,j
    real(8),dimension(Numbodies,3)::relforce
    real(8)::h

    do i=1,numbodies
       system%position(i,1)=system%position(i,1)+h*system%velocity(i,1) - (h*h/2.d0)*relforce(i,1)
       system%position(i,2)=system%position(i,2)+h*system%velocity(i,2) - (h*h/2.d0)*relforce(i,2)
       system%position(i,3)=system%position(i,3)+h*system%velocity(i,3) - (h*h/2.d0)*relforce(i,3)
    end do

  end subroutine calc_position

  subroutine calc_velocities(system,numbodies,relforce,updatedforce,h)
    implicit none
    class(solver),intent(inout)::system
    integer,intent(in)::NumBodies
    integer::i,j
    real(8)::h
    real(8),dimension(Numbodies,3)::relforce
    real(8),dimension(Numbodies,3)::updatedforce

    do i=1, numbodies
       system%velocity(i,1)=system%velocity(i,1)-h*0.5*updatedforce(i,1)-h*0.5*relforce(i,1)
       system%velocity(i,2)=system%velocity(i,2)-h*0.5*updatedforce(i,2)-h*0.5*relforce(i,2)
       system%velocity(i,3)=system%velocity(i,3)-h*0.5*updatedforce(i,3)-h*0.5*relforce(i,3)
    end do

  end subroutine calc_velocities

  subroutine kinetic_energy(system,numbodies,kinetic)
    implicit none
    class(solver), intent(in)::system
    integer,intent(in)::Numbodies
    integer::i
    real(8),dimension(numbodies+1)::kinetic
    real(8)::totalke

    totalke=0

    do i =1,numbodies
       kinetic(i)=(1.d0/2.d0)*system%mass(i)*(system%velocity(i,1)*system%velocity(i,1)+system%velocity(i,2)*system%velocity(i,2)+system%velocity(i,3)*system%velocity(1,3))
       totalke=totalke+kinetic(i)
    end do

    kinetic(numbodies+1)=totalke
  end subroutine kinetic_energy

  subroutine potential_energy(system, numbodies,relposition,potential)
    implicit none
    class(solver), intent(in)::system
    integer,intent(in)::Numbodies
    integer::i,j
    real(8),dimension(numbodies+1)::potential
    real(8),dimension(numbodies,numbodies,4)::relposition
    real(8)::totalpe

    totalpe=0
    do i=1,numbodies+1
       potential(i)=0.d0
    end do

    do i=1,numbodies
      do j=1,NumBodies
         if (i .ne. j ) then
            potential(i)=potential(i)+(4*3.14*3.14*system%mass(i)*system%mass(j)/relposition(j,i,4))
         end if
      end do
      totalpe=totalpe+potential(i)
    end do

    potential(numbodies+1)=totalpe
  end subroutine potential_energy

  subroutine angular_momentum(system,numbodies,relposition,angular)
    implicit none
    class(solver),intent(in)::system
    integer,intent(in)::Numbodies
    integer::i,j
    real(8),dimension(numbodies+1)::angular
    real(8),dimension(numbodies,numbodies,3)::relposition
    real(8)::totalang

    totalang=0

    do i=1,numbodies
       angular(i)=system%mass(i)*relposition(1,i,4)*(sqrt(system%velocity(i,1)**2.d0 + system%velocity(i,2)**2.d0 + system%velocity(i,3)**2.d0))
       totalang=totalang+angular(i)
    end do

    angular(numbodies+1)=totalang
  end subroutine angular_momentum

end module solver_class