      SUBROUTINE polint( xa, ya, n, x, y, dy )
c     Polynomial interpolation.  "Numerical Recipes", page 82 (sect 3.1)
c  Given array XA and YA, each of length N, and given a value X, this
c  routine returns a value Y, and an error estimate DY.  If P(x) is the
c  polynomial of degree N-1 such that P(XA) = YA, i = 1,...N, then
c  the returned value Y = P(X)
c
      PARAMETER (nmax = 10)                                             ! the largest anticipated value of N
      DIMENSION xa(n), ya(n), c(nmax), d(nmax)
      ns = 1
      dif = ABS(x-xa(1))
      DO 11 i = 1, n
         dift = ABS(x-xa(i))
         IF( dift .LT. dif ) THEN
             ns = i
             dif = dift
         ENDIF
         c(i) = ya(i)
         d(i) = ya(i)
   11 CONTINUE
      y = ya(ns)
      ns = ns - 1
      DO 13 m = 1, n-1
         DO 12 i = 1, n-m
            ho = xa(i) - x
            hp = xa(i+m) - x
            w = c(i+1) - d(i)
            den = ho - hp
            IF( den .EQ. 0. ) RETURN                                    ! if two input xa's are identical
            den = w / den
            d(i) = hp * den
            c(i) = ho * den
   12    CONTINUE
         IF( 2*ns .LT. n-m ) THEN
             dy = c(ns+1)
         ELSE
             dy = d(ns)
             ns = ns - 1
         ENDIF
         y = y + dy
   13 CONTINUE
      RETURN
      END


      PROGRAM xfrprmn
C     driver for routine frprmn
      INTEGER NDIM
      REAL FTOL,PIO2
      PARAMETER(NDIM=3,FTOL=1.0E-6,PIO2=1.5707963)
      INTEGER iter,k
      REAL angl,fret,p(NDIM)
      write(*,'(/1x,a)') 'Program finds the minimum of a function'
      write(*,'(1x,a)') 'with different trial starting vectors.'
      write(*,'(1x,a)') 'True minimum is (0.5,0.5,0.5)'
      do 11 k=0,4
        angl=PIO2*k/4.0
        p(1)=2.0*cos(angl)
        p(2)=2.0*sin(angl)
        p(3)=0.0
        write(*,'(/1x,a,3(f6.4,a))') 'Starting vector: (',
     *       p(1),',',p(2),',',p(3),')'
        call frprmn(p,NDIM,FTOL,iter,fret)
        write(*,'(1x,a,i3)') 'Iterations:',iter
        write(*,'(1x,a,3(f6.4,a))') 'Solution vector: (',
     *       p(1),',',p(2),',',p(3),')'
        write(*,'(1x,a,e14.6)') 'Func. value at solution',fret
11    continue
      END
      REAL FUNCTION func(x)
      REAL bessj0,x(3)
      func=1.0-bessj0(x(1)-0.5)*bessj0(x(2)-0.5)*bessj0(x(3)-0.5)
      END
      SUBROUTINE dfunc(x,df)
      INTEGER NMAX
      PARAMETER (NMAX=50)
      REAL bessj0,bessj1,x(3),df(NMAX)
      df(1)=bessj1(x(1)-0.5)*bessj0(x(2)-0.5)*bessj0(x(3)-0.5)
      df(2)=bessj0(x(1)-0.5)*bessj1(x(2)-0.5)*bessj0(x(3)-0.5)
      df(3)=bessj0(x(1)-0.5)*bessj0(x(2)-0.5)*bessj1(x(3)-0.5)
      return
      END

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


PROGRAM Random

  INTEGER, PARAMETER :: n = 1000
  INTEGER :: i
  REAL :: array(n), pi, temp, mean = 1.0, sd = 0.5

  pi = 4.0*ATAN(1.0)
  CALL RANDOM_NUMBER(array) ! Uniform distribution

! Now convert to normal distribution
  DO i = 1, n-1, 2
    temp = sd * SQRT(-2.0*LOG(array(i))) * COS(2*pi*array(i+1)) + mean
    array(i+1) = sd * SQRT(-2.0*LOG(array(i))) * SIN(2*pi*array(i+1)) + mean
    array(i) = temp
  END DO

! Check mean and standard deviation
  mean = SUM(array)/n
  sd = SQRT(SUM((array - mean)**2)/n)

  WRITE(*, "(A,F8.6)") "Mean = ", mean
  WRITE(*, "(A,F8.6)") "Standard Deviation = ", sd

END PROGRAM Random


module astronomy
    use, intrinsic :: iso_fortran_env, dp=>real64
    use math, only: PI, &
                    multiplyMatrixByVector
    implicit none

    private

    public :: CTK, &
              TRAN_MATR, &
              convertGalacticToXYZ, &
              convertEquatorToGalact, &
              convertHoursToRad, &
              convertDegreesToRad, &
              convertEquatorMotionToUVW

    ! Astronomical unit in km/s
    real*8, parameter :: CTK = 4.74047d0
    ! Transformation matrix from equatorial to galactic coordinates
    real*8, parameter, dimension(3, 3) :: TRAN_MATR &
        = reshape( (/-0.054875d0,-0.873437d0,-0.483835d0,&
                      0.494109d0,-0.444829d0, 0.746982d0,&
                     -0.867666d0,-0.198076d0, 0.455983d0/),&
                     shape(TRAN_MATR), order = (/2,1/))
    ! Right ascension of Galactic pole
    real*8, parameter :: RA_GPOLE = 192.859508d0 * PI / 180.d0
    ! Declination of Galactic pole
    real*8, parameter :: DEC_GPOLE = 27.128336d0 * PI /180.d0
    ! Auxiliary angle
    real*8, parameter :: AUX_ANGLE = 122.932d0 * PI / 180.d0

contains

    function convertGalacticToXYZ(r, l, b) result(coordinate)
        real*8, intent(in) :: r, l, b
        real*8, dimension(3) :: coordinate

        coordinate(1) = r * dcos(b) * dcos(l)
        coordinate(2) = r * dcos(b) * dsin(l)
        coordinate(3) = r * dsin(b)
    end function

    elemental function convertHoursToRad(angleInHours) result(angleInRadians)
        character(len = 11), intent(in) :: angleInHours
        real*8 angleInRadians
        real*8 hours,minutes,seconds

        read(angleInHours(1:2), *) hours
        read(angleInHours(4:5), *) minutes
        read(angleInHours(7:11), *) seconds
        angleInRadians = (hours+(minutes+seconds/60.d0)/60.d0) * 15.d0 &
                         * pi / 180.d0
    end function convertHoursToRad

    elemental function convertDegreesToRad(angleInDegrees) result(angleInRadians)
        character(len = 11), intent(in) :: angleInDegrees
        real*8 angleInRadians
        real*8 degrees, arcmins, arcsecs

        read(angleInDegrees(1:2), *) degrees
        read(angleInDegrees(4:5), *) arcmins
        read(angleInDegrees(7:11), *) arcsecs
        angleInRadians = (degrees+(arcmins+arcsecs/60.d0)/60.d0) * pi / 180.d0
    end function convertDegreesToRad

    subroutine convertEquatorToGalact(ra,dec,l,b)
        real*8,intent(in) :: ra,dec
        real*8,intent(out) :: l,b
        real*8 x,y

        !$b=arcsin\Big(cos(\delta)cos(\delta_{G})cos(\alpha-\alpha_{G})+\\+sin(\delta)sin(\delta_{G})\Big)$
        b = (dasin(dcos(dec)*dcos(DEC_GPOLE)*dcos(ra-RA_GPOLE)&
            + dsin(dec)*dsin(DEC_GPOLE))) !lattitude
        x = dsin(dec) - dsin(b)*dsin(DEC_GPOLE)
        y = dcos(dec) * dsin(ra-RA_GPOLE) * dcos(DEC_GPOLE)
        l = datan(x/y) + AUX_ANGLE - PI/2.d0 !longitude
        if (x.gt.0.d0 .AND. y.lt.0.d0) then
            l = l + PI
        else if (x.lt.0.d0 .AND. y.lt.0.d0) then
            l = l + PI
        else if (x.lt.0.d0 .AND. y.gt.0.d0) then
            l = l + 2.d0*PI
        else if (l .gt. 2.d0*PI) then
            l = l - 2.d0*PI
        end if
    end subroutine

    subroutine convertEquatorMotionToUVW(rightAscension, &
                                         declination, &
                                         distance, &
                                         motionInDEC, &
                                         motionInRA, &
                                         vel_hel)
        real*8, intent(in) :: rightAscension, &
                              declination, &
                              distance, &
                              motionInDEC, &
                              motionInRA
        real*8, dimension(3), intent(out) :: vel_hel
        real(dp), parameter :: VEL_RAD = 0.d0
        real(dp) :: motionInRAAster
        real(dp), dimension(3) :: vel_motion = (/VEL_RAD, 0.d0, 0.d0/)
        real*8, dimension(3, 3) :: rotationMatrix

        ! Motion in right ascension with asterisk
        motionInRAAster = motionInRA * dcos(declination)

        vel_motion(2) = CTK * motionInRAAster * distance
        vel_motion(3) = CTK * motionInDEC * distance

        call fillRotationMatrix(rightAscension, declination, rotationMatrix)

        ! U,V,W
        vel_hel = multiplyMatrixByVector(TRAN_MATR, &
                        multiplyMatrixByVector(rotationMatrix,&
                                                       vel_motion))
    end subroutine convertEquatorMotionToUVW

    subroutine fillRotationMatrix(RA, DEC, A)

        real*8, intent(in) :: RA, &
                              DEC
        real*8, dimension(3, 3), intent(out) :: A
        A(1,1) = dcos(RA) * dcos(DEC)
        A(2,1) = dsin(RA) * dcos(DEC)
        A(3,1) = dsin(DEC)

        A(1,2) = - dsin(RA)
        A(2,2) = dcos(RA)
        A(3,2) = 0.d0

        A(1,3) = - dcos(RA)*dsin(DEC)
        A(2,3) = - dsin(RA)*dsin(DEC)
        A(3,3) = dcos(DEC)

    end subroutine

end module


	program lu

	implicit none
	real,allocatable,dimension(:,:)::A,L,U
	integer:: k,h,j,n,m,i

	call matriz(A,n,m)

	allocate(L(n,m),U(n,m))

! esta A se reduce la diagonal inferior y queda la matriz U y la matriz L
!primero hago que U sea igual a A
	U=A
	do h= 1,m

	   do j= 1,n
!aca dice la parte triangular inferior o mejor dicho cuando tengo las filas mas grande que las columnas
	if (j>h) then
	   do k=1,m
	   	U(j,k)=A(j,k)-(A(j,h)/A(h,h))*A(h,k)

	   end do

	L(j,h)=(A(j,h)*(1/A(h,h)))

	else if (j==h) then

	 L(j,h)=1

	else
	 L(j,h)=0

	end if

	  end do

!despues reemplazo A por la nueva U y listo

	A=U
	end do

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

	Write(*,*)"La matriz L :"

	do i=1,n,1

	write(*,*) L(i,:)
	end do

		Write(*,*)"La U :"

	do i=1,n,1

	write(*,*) U(i,:)
	end do

	A=matmul(L,U)

		Write(*,*)"La A :"

	do i=1,n,1

	write(*,*) A(i,:)
	end do

	  deallocate(A,L)
!---------------------------------------------------------

	contains

!---------------------------------------------------------
	subroutine matriz(mat,fila,colum)

	real,allocatable,dimension(:,:)::mat
	integer:: fila,colum,fila2,colum2,i

	Write(*,*) "Ingrese las dimenciones de la matriz"
	Write(*,*) "Filas"
	read(*,*) fila
	Write(*,*) "Columnas"
	read(*,*) colum

	allocate(mat(fila,colum))

	write(*,*) "Ingrese los elementos de la matriz"

	 fila2=1
	 colum2=1

	 do while(fila2<=fila)

	   do while(fila2<=fila.and.colum2<=colum)

	   Write(*,*)"Ingrese el elemento de la matriz",fila2,",",colum2

	   read(*,*)mat(fila2,colum2)
	   colum2=colum2+1
	   end do

	   fila2=fila2+1
	   colum2=1

	  enddo

	Write(*,*)"La matriz ingresada fue :"

	do i=1,fila,1

	write(*,*) mat(i,:)
	end do

	end subroutine

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

 	end program


 FUNCTION isPrime(number)
   LOGICAL :: isPrime
   INTEGER, INTENT(IN) :: number
   INTEGER :: i

   IF(number==2) THEN
      isPrime = .TRUE.
   ELSE IF(number < 2 .OR. MOD(number,2) == 0) THEN
      isPRIME = .FALSE.
   ELSE
      isPrime = .TRUE.
      DO i = 3, INT(SQRT(REAL(number))), 2
         IF(MOD(number,i) == 0) THEN
            isPrime = .FALSE.
            EXIT
         END IF
      END DO
   END IF
 END FUNCTION


program sin_04
use iso_fortran_env, only: dp => real64
implicit none
real(dp), parameter :: x = sin(1.5_dp)
if (abs(x - 0.997494996_dp) > 1e-5_dp) error stop
end program


program testNumerical
    use num_utils
    implicit none
    ! Test Bisection Method
    print*, "----------------------------------------"
    print*, " Test For Bisection root finding Method "
    print*, "----------------------------------------"
    call testBisection(rootTestFn)

    print*, "-------------------------------------"
    print*, " Test For Newton root finding Method "
    print*, "-------------------------------------"
    call testNewtonRoot(rootTestFn, rootTestDFn)

contains

    subroutine testBisection(fun)
        use num_utils, only : bisect
        interface
            real function fun(x)
                real, intent(in) :: x
            end function fun
        end interface
        real :: xa, xb, tol, xval
        !external fn
        xa = 1.0
        xb = 2.0
        tol = 0.001
        call bisect(xa, xb, tol, xval, fun)
        write(*, "('xval = ', f6.2, ', tolerance = ', f7.3)") xval, tol
    end subroutine testBisection

    subroutine testNewtonRoot(fn, dfn)
        use num_utils, only: newtonRoot
        interface
            real function fn(x)
                real, intent(in) :: x
            end function fn
            real function dfn(x)
                real, intent(in) :: x
            end function dfn
        end interface
        real :: x0, tol, xval
        x0 = 1.0
        tol = 0.001

        call newtonRoot(x0, tol, xval, fn, dfn)
        write(*, "('xval = ', f6.2, ', tolerance = ', f7.3)") xval, tol
    end subroutine testNewtonRoot

    real function rootTestFn(x) result(fn)
        real, intent(in) :: x
        fn = (x*x*x) + x - 3.0
    end function rootTestFn

    real function rootTestDFn(x) result(dfn)
        real, intent(in) :: x
        dfn = 3.0 * (x*x) + 1.0
    end function rootTestDFn

end program testNumerical


program demo_math_is_close
    use forlab_math,  only: is_close
    use stdlib_error, only: check
    real :: x(2) = [1, 2]
    print *, is_close(x,[real :: 1, 2.1])        !! [T, F]
    print *, is_close(2.0, 2.1, abs_tol=0.1)     !! T
    call check(all(is_close(x, [2.0, 2.0])), msg="all(is_close(x, [2.0, 2.0])) failed.", warn=.true.)
        !! all(is_close(x, [2.0, 2.0])) failed.
end program demo_math_is_close


    MODULE random_uniform_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_uniform(low,high)
! .. Use Statements ..
        USE random_standard_uniform_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_uniform
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: high, low
! ..
! .. Executable Statements ..

!**********************************************************************
!     REAL FUNCTION GENUNF( LOW, HIGH )
!               GeNerate Uniform Real between LOW and HIGH
!                              Function
!     Generates a real uniformly distributed between LOW and HIGH.
!                              Arguments
!     LOW --> Low bound (exclusive) on real value to be generated
!                         REAL LOW
!     HIGH --> High bound (exclusive) on real value to be generated
!                         REAL HIGH
!**********************************************************************
        IF (low>high) THEN
          WRITE (*,*) 'LOW > HIGH in GENUNF: LOW ', low, ' HIGH: ', high
          WRITE (*,*) 'Abort'
          STOP 'LOW > High in GENUNF - Abort'
        END IF

        random_uniform = low + (high-low)*random_standard_uniform()

        RETURN

      END FUNCTION random_uniform

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

    END MODULE random_uniform_mod


program unitytest
! Program for testing LU and Inverse Process
! Load LU Decomposition
use LUDecomposition

  ! Variables
  integer :: n, i

  ! Parameters
  integer, parameter :: maxn = 4
  integer, allocatable  :: indx(:)
  real, allocatable :: matrix(:,:)

  do n = 4 , maxn
    allocate( indx(n), matrix(n, n))
    indx =  (/ (I, I = 1, n) /)
    print *,indx
    call RANDOM_NUMBER(matrix)
    matrix = 100*matrix
    do i = 1, n
      print*,matrix(i,:)
    end do
    call ludcmp_square(matrix, n, indx)

    call LUResults(matrix, n)

    !do i = 1, n
    !  print*,matrix(i,:)
    !end do

    call ArrengeMatrix(matrix, indx, n)

    do i = 1, n
      print*,matrix(i,:)
    end do

    print*, indx

    deallocate( indx, matrix)
  end do

end program unitytest

subroutine LUResults(matrix,n)

  real, intent(inout) :: matrix(n,n)
  real :: L(n,n), U(n,n)
  integer :: i, j, k

  do i = 1, n
    L(i,i) = 1.0
    do j = 1, n
      if (i>j) then
        L(i,j) = matrix(i,j)
        U(i,j) = 0.0
      end if
      if (i<=j) then
        U(i,j) = matrix(i,j)
      end if
      if (i<j) then
        L(i,j) = 0.0
      end if
    end do
  end do

  do i = 1, n
    do j = 1, n
      matrix(i,j) = 0.0
      do k = 1, n
        matrix(i,j) = matrix(i,j) + L(i,k)*U(k,j)
      end do
    end do
  end do

end subroutine LUResults

subroutine ArrengeMatrix(matrix, indx, n)

  real, intent(inout) :: matrix(n,n)
  integer, intent(in) :: indx(n)
  real :: temp
  integer :: i, j

  do i = n, 1, -1
    if (i /= indx(i)) then
      do j = 1, n
        temp = matrix(i,j)
        matrix(i,j) = matrix(indx(i),j)
        matrix(indx(i),j) = temp
      end do
    end if
  end do
end subroutine ArrengeMatrix


!Dot Product
program Dot_Product_Fortan
    implicit none

    real, DIMENSION(2) :: a, b

    a = (/1, 2/)
    b = (/3, 4/)

    print *, "Dot product of a and b is", dot_product(a, b)
    print *, ""

end program Dot_Product_Fortan


module regression

  implicit none
  type :: reg_type
    integer :: n = 0
    real :: xy = 0.
    real :: xsum = 0.
    real :: ysum = 0.
    real :: x2sum = 0.
    real :: a, b
  end type reg_type

  interface regress
     module procedure regress_0, regress_1, regress_2
  end interface

contains

  subroutine regress_0 (reg, x, y, a, b)
    type (reg_type), target :: reg
    real, intent (in) :: x, y
    real, intent (out), optional :: a, b

    integer, pointer :: n
    real, pointer :: xy, xsum, ysum, x2sum

    n     => reg % n
    xy    => reg % xy
    xsum  => reg % xsum
    ysum  => reg % ysum
    x2sum => reg % x2sum

    n = n + 1
    xy = xy + x*y
    xsum = xsum + x
    ysum = ysum + y
    x2sum = x2sum + x*x

    if (n > 1) then
       reg%b = (xy-xsum*ysum/real(n))/(x2sum-xsum*xsum/real(n))
       reg%a = ysum/real(n) - reg%b*xsum/real(n)
    else
       reg%b = 0.
       reg%a = 0.
    end if

    if (present(a)) then
       b=reg%b
       a=reg%a
    end if

  end subroutine regress_0

  subroutine regress_1 (reg, x, y, a, b)
    type (reg_type), target :: reg
    real, dimension(:), intent (in) :: x, y
    real, dimension(:), intent (out), optional :: a, b

    integer, pointer :: n
    real, pointer :: xy, xsum, ysum, x2sum

    n     => reg % n
    xy    => reg % xy
    xsum  => reg % xsum
    ysum  => reg % ysum
    x2sum => reg % x2sum

    n = n + 1
    xy = xy + sum(x*y)
    xsum = xsum + sum(x)
    ysum = ysum + sum(y)
    x2sum = x2sum + sum(x*x)

    if (n>1) then
       reg%b = (xy-xsum*ysum/real(n))/(x2sum-xsum*xsum/real(n))
       reg%a = ysum/real(n) - reg%b*xsum/real(n)
    else
       reg%b = 0.
       reg%a = 0.
    end if

    if (present(a)) then
       b=reg%b
       a=reg%a
    end if

  end subroutine regress_1

  subroutine regress_2 (reg, x, y, a, b)
    type (reg_type), dimension(:), target :: reg
    real, dimension(:), intent (in) :: x, y
    real, dimension(:), intent (out), optional :: a, b

    integer, dimension(:), pointer :: n
    real, dimension(:), pointer :: xy, xsum, ysum, x2sum

    n     => reg % n
    xy    => reg % xy
    xsum  => reg % xsum
    ysum  => reg % ysum
    x2sum => reg % x2sum

    n = n + 1
    xy = xy + x*y
    xsum = xsum + x
    ysum = ysum + y
    x2sum = x2sum + x*x

    if (n(1)>1) then
       reg%b = (xy-xsum*ysum/real(n))/(x2sum-xsum*xsum/real(n))
       reg%a = ysum/real(n) - reg%b*xsum/real(n)
    else
       reg%b = 0.
       reg%a = 0.
    end if

    if (present(a)) then
       b=reg%b
       a=reg%a
    end if

  end subroutine regress_2

  elemental function yp (reg, x)
    real :: yp
    type (reg_type), intent (in) :: reg
    real, intent (in) :: x

    yp = reg%a + reg%b*x

  end function yp

  elemental function xp (reg, y)
    real :: xp
    type (reg_type), intent (in) :: reg
    real, intent (in) :: y

    if (reg%b == 0.) then
       xp = 100.
    else
       xp = (y-reg%a)/reg%b
    end if

  end function xp

end module regression


!--------------------------------------------------
!PHY2063 Task 2
!URN 6309823 - Penguin Lab Group 1B
!October 15th 2015
!--------------------------------------------------

PROGRAM Task2
  IMPLICIT NONE

  REAL    :: r,massdash_S,h,mass_mid,massdash_mid
  INTEGER :: i

  REAL, DIMENSION(1:301) :: mass
  REAL, DIMENSION(1:301) :: t
  REAL, DIMENSION(1:301) :: Error

  !Open Files to store data

  OPEN(unit=12,file='Task2.dat')

  !Assign Values  (r=rate, h=step, t=time, M=mass)
  !Error is error in Euler estimate

  r=0.3
  h=0.1
  t(1)=0
  mass(1)=0.1
  Error(1)=mass(1)-0.1*exp(-0.3*t(1))

  WRITE(12,'e5.8') t(1),mass(1),error(1)

  !Euler method

  DO i=1,300

  !Use these values at the midpoint

    !t_mid=t(i)+0.5*h   not used therefore not needed.
    massdash_s=-r*mass(i)
    mass_mid=mass(i)+0.5*h*massdash_s
    massdash_mid=-r*mass_mid

    !Input these values into the formulae below

    t(i+1)=t(i)+h
    mass(i+1)=mass(i)+h*massdash_mid

    error(i+1)=mass(i+1)-0.1*exp(-0.3*t(i+1))

    !Write the values in the array to Task2.dat

    WRITE(12,'e5.8') t(i+1),mass(i+1),error(i+1)
  END DO

  CLOSE(12)

!Run Program
!Run gnuplot
!Write "plot "Task2.dat" using 1:2 with lines" in the terminal

!Compare to Task1: Run gnuplot
!Write "plot "Task1.dat" using 1:2 with lines" in the terminal

!Find error: Run gnuplot
!Write "plot "Task2.dat" using 1:3 with lines" in the terminal

END PROGRAM Task2


     PROGRAM bigsum
        IMPLICIT NONE
        INTEGER :: n
        CHARACTER(LEN=1000) :: line
        INTEGER, PARAMETER :: MAXLEN = 1000
        INTEGER, DIMENSION(0:MAXLEN - 1) :: num
        INTEGER :: beginI
        INTEGER :: endI
        INTEGER :: endS
        INTEGER :: i
        INTEGER :: j
        INTEGER :: k
        INTEGER :: overflow

        DO i = 0, MAXLEN - 1
           num(i) = 0
        END DO

        READ *, n
        READ '(A)', line
        beginI = 0
        endI = 0
        endS = LEN(line)
        i = 0
        DO i = 1, n
           beginI = endI + 1
           endI = beginI + 1
           DO WHILE ((endI < endS) .AND. (line(endI:endI) /= " "))
              endI = endI + 1
           END DO
           k = 0
           DO j = endI - 1, beginI, -1
              num(k) = num(k) + (IACHAR(line(j:j)) - IACHAR("0"))
              k = k + 1
           END DO
        END DO

        overflow = 0
        DO i = 0, MAXLEN - 1
           num(i) = num(i) + overflow
           overflow = num(i)/10
           num(i) = MOD(num(i), 10)
        END DO

        j = MAXLEN - 1
        DO WHILE (num(j) == 0)
           j = j - 1
        END DO

        DO WHILE (j >= 0)
           WRITE (*, "(I0)", advance="no") num(j)
           j = j - 1
        END DO
        PRINT '(A)', ""

     END PROGRAM bigsum


function DownContFilterMA(l, half, r, d)
!------------------------------------------------------------------------------
!
!   This function will compute the minimum amplitude downward continuation
!   filter of Wieczorek and Phillips 1998 for degree l, where the filter is
!   assumed to be equal to 0.5 at degree half.
!
!   Calling Parameters
!
!       l       Spherical harmonic degree
!       half    Spherical harmonic degree where the filter is 0.5
!       r       Reference radius for surface gravity field
!       d       Mean radius of downward continuation
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: DownContFilterMA
    integer(int32), intent(in) :: l, half
    real(dp), intent(in) :: r, d
    real(dp) :: const

    if (l < 0) then
        print*, "Error --- DownContFilterMA"
        print*, "L must be greater or equal to zero."
        print*, "Input value = ", l
        stop
    end if

    if (half == 0) then
        DownContFilterMA = 1.0_dp

    else
        const = (dble(2*half+1) * (r / d)**half )**2
        const = 1.0_dp / const

        DownContFilterMA = 1.0_dp + const * ( dble(2*l+1) * (r / d)**l )**2
        DownContFilterMA = 1.0_dp / DownContFilterMA

    end if

end function DownContFilterMA

function DownContFilterMC(l, half, r, d)
!------------------------------------------------------------------------------
!
!   This function will compute a minimum curvature downward continuation
!   filter for degree l, where the filter is assumed to be equal to 0.5 at
!   degree half.
!
!   Calling Parameters
!
!       l       Spherical harmonic degree
!       half    Spherical harmonic degree where the filter is 0.5
!       r       Reference radius for surface gravity field
!       d       Mean radius of downward continuation
!
!   Note: This filter is analogous to (and numerically very similar to)
!       the minimum curvature filter in Phipps Morgan and Blackman (1993)
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: DownContFilterMC
    integer(int32), intent(in) :: l, half
    real(dp), intent(in) :: r, d
    real(dp) :: const

    if (l < 0) then
        print*, "Error --- DownContFilterMC"
        print*, "L must be greater or equal to zero."
        print*, "Input value = ", l
        stop
    end if

    if (half == 0) then
        DownContFilterMC = 1.0_dp

    else
        const = dble(half * half+half) * ( dble(2*half+1) * (r / d)**half)**2
        const = 1.0_dp / const

        DownContFilterMC = 1.0_dp + const * dble(l*l+l) * (dble(2*l+1) * (r/d)**l)**2
        DownContFilterMC = 1.0_dp / DownContFilterMC

    end if

end function DownContFilterMC


module matrix

contains

! A[r,s] * B[s,t] = C[r,t]
subroutine matrix_multiply(A,r,s,B,t,C)
	integer :: r, s, t
	real, intent(in) :: A(r,s)
	real, intent(in) :: B(s,t)
	real, intent(out) :: C(r,t)

	C = matmul(A,B)
end subroutine matrix_multiply

! A[r,s] * B[s,t] = C[r,t]
subroutine matrix_multiply2(A,r,s,B,t,C)
        integer :: r, s, t
        real, intent(in) :: A(r,s)
        real, intent(in) :: B(s,t)
        real, intent(inout) :: C(r,t)

        C = matmul(A,B)
end subroutine matrix_multiply2

end module matrix


Module m_mulcnt
Use m_uniinv
Private
Integer, Parameter :: kdp = selected_real_kind(15)
public :: mulcnt
private :: kdp
private :: R_mulcnt, I_mulcnt, D_mulcnt
interface mulcnt
  module procedure d_mulcnt, r_mulcnt, i_mulcnt
end interface mulcnt
contains

Subroutine D_mulcnt (XDONT, IMULT)
!   MULCNT = Give for each array value its multiplicity
!            (number of times that it appears in the array)
! __________________________________________________________
!  Michel Olagnon - Mar. 2000
! __________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (In) :: XDONT
      Integer, Dimension (:), Intent (Out) :: IMULT
! __________________________________________________________
!
      Integer, Dimension (Size(XDONT)) :: IWRKT
      Integer, Dimension (Size(XDONT)) :: ICNTT
      Integer :: ICRS
! __________________________________________________________
      Call UNIINV (XDONT, IWRKT)
      ICNTT = 0
      Do ICRS = 1, Size(XDONT)
            ICNTT(IWRKT(ICRS)) = ICNTT(IWRKT(ICRS)) + 1
      End Do
      Do ICRS = 1, Size(XDONT)
            IMULT(ICRS) = ICNTT(IWRKT(ICRS))
      End Do

!
End Subroutine D_mulcnt

Subroutine R_mulcnt (XDONT, IMULT)
!   MULCNT = Give for each array value its multiplicity
!            (number of times that it appears in the array)
! __________________________________________________________
!  Michel Olagnon - Mar. 2000
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (In) :: XDONT
      Integer, Dimension (:), Intent (Out) :: IMULT
! __________________________________________________________
!
      Integer, Dimension (Size(XDONT)) :: IWRKT
      Integer, Dimension (Size(XDONT)) :: ICNTT
      Integer :: ICRS
! __________________________________________________________
      Call UNIINV (XDONT, IWRKT)
      ICNTT = 0
      Do ICRS = 1, Size(XDONT)
            ICNTT(IWRKT(ICRS)) = ICNTT(IWRKT(ICRS)) + 1
      End Do
      Do ICRS = 1, Size(XDONT)
            IMULT(ICRS) = ICNTT(IWRKT(ICRS))
      End Do

!
End Subroutine R_mulcnt
Subroutine I_mulcnt (XDONT, IMULT)
!   MULCNT = Give for each array value its multiplicity
!            (number of times that it appears in the array)
! __________________________________________________________
!  Michel Olagnon - Mar. 2000
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (In)  :: XDONT
      Integer, Dimension (:), Intent (Out) :: IMULT
! __________________________________________________________
!
      Integer, Dimension (Size(XDONT)) :: IWRKT
      Integer, Dimension (Size(XDONT)) :: ICNTT
      Integer :: ICRS
! __________________________________________________________
      Call UNIINV (XDONT, IWRKT)
      ICNTT = 0
      Do ICRS = 1, Size(XDONT)
            ICNTT(IWRKT(ICRS)) = ICNTT(IWRKT(ICRS)) + 1
      End Do
      Do ICRS = 1, Size(XDONT)
            IMULT(ICRS) = ICNTT(IWRKT(ICRS))
      End Do

!
End Subroutine I_mulcnt
end module m_mulcnt


!*******************************************************************************
!   Copyright(C) 2004-2012 Intel Corporation. All Rights Reserved.
!
!   The source code, information  and  material ("Material") contained herein is
!   owned  by Intel Corporation or its suppliers or licensors, and title to such
!   Material remains  with Intel Corporation  or its suppliers or licensors. The
!   Material  contains proprietary information  of  Intel or  its  suppliers and
!   licensors. The  Material is protected by worldwide copyright laws and treaty
!   provisions. No  part  of  the  Material  may  be  used,  copied, reproduced,
!   modified, published, uploaded, posted, transmitted, distributed or disclosed
!   in any way  without Intel's  prior  express written  permission. No  license
!   under  any patent, copyright  or  other intellectual property rights  in the
!   Material  is  granted  to  or  conferred  upon  you,  either  expressly,  by
!   implication, inducement,  estoppel or  otherwise.  Any  license  under  such
!   intellectual  property  rights must  be express  and  approved  by  Intel in
!   writing.
!
!   *Third Party trademarks are the property of their respective owners.
!
!   Unless otherwise  agreed  by Intel  in writing, you may not remove  or alter
!   this  notice or  any other notice embedded  in Materials by Intel or Intel's
!   suppliers or licensors in any way.
!
!*******************************************************************************
!   Content : MKL PARDISO Fortran-90 example
!
!*******************************************************************************
!----------------------------------------------------------------------
! Example program to show the use of the "PARDISO" routine
! for symmetric linear systems
!---------------------------------------------------------------------
INCLUDE 'mkl_pardiso.f90'
subroutine Poisson_2D

USE mkl_pardiso
use variables
use constants

IMPLICIT NONE
!.. Internal solver memory pointer
TYPE(MKL_PARDISO_HANDLE), ALLOCATABLE  :: pt(:)
!.. All other variables

INTEGER maxfct, mnum, mtype, phase, nrhs, error, msglvl
INTEGER error1
INTEGER, ALLOCATABLE :: iparm( : )
INTEGER, ALLOCATABLE :: ia( : )
INTEGER, ALLOCATABLE :: ja( : )
double precision, ALLOCATABLE :: a( : )
double precision, ALLOCATABLE :: b( : )
double precision, ALLOCATABLE :: x( : )
INTEGER i,j,k, idum(1)
double precision ddum(1)
double precision CD
!.. Fill all arrays containing matrix data.
nrhs = 1
maxfct = 1
mnum = 1
ALLOCATE( ia ( n + 1 ) )
!ia = (/ 1, 4, 7, 10, 13, 15, 17, 18, 19 /)
ALLOCATE( ja ( nnz ) )
!ja = (/ 1, 2  3,       6, 7,    &
!           2, 3,    5,          &
!              3,             8, &
!                 4,       7,    &
!                    5, 6, 7,    &
!                       6,    8, &
!                          7,    &
!                             8 /)
ALLOCATE( a ( nnz ) )
!a = (/-4.d0,  1.d0,             1.d0,                    &
!             -4.d0, 1.d0,            1.d0,               &
!                    -4.d0, 1.d0,            1.d0,        &
!                          -4.d0,                  1.d0,  &
!                                -4.d0, 1.d0,             &
!                                     -4.d0, 1.d0,        &
!                                           -4.d0, 1.d0,  &
!                                                  -4.d0 /)
j=0
do i=1,n
   j=j+1
   ia(i)=j
   CD=-4.d0
   if (i.le.(np)) CD=CD+1.d0
   if (i.gt.(n-np)) CD=CD+1.d0
   if (Mod(i,np).eq.0) CD=CD+1.d0
   if (Mod(i-1,np).eq.0) CD=CD+1.d0
   a(j)=CD
   ja(j)=i
   if (Mod(i,np).gt.0) then
       j=j+1
       a(j)=1.d0
       ja(j)=i+1
   endif
   if (i.le.(n-np)) then
       j=j+1
       a(j)=1.d0
       ja(j)=i+np
   endif
enddo
ia(n+1)=j+1

ALLOCATE( b ( n ) )
ALLOCATE( x ( n ) )
!..
!.. Set up PARDISO control parameter
!..
ALLOCATE( iparm ( 64 ) )

do i = 1, 64
   iparm(i) = 0
end do

iparm(1) = 1 ! no solver default
iparm(2) = 2 ! fill-in reordering from METIS
iparm(4) = 0 ! no iterative-direct algorithm
iparm(5) = 0 ! no user fill-in reducing permutation
iparm(6) = 0 ! =0 solution on the first n compoments of x
iparm(8) = 9 ! numbers of iterative refinement steps
iparm(10) = 13 ! perturbe the pivot elements with 1E-13
iparm(11) = 0 ! use nonsymmetric permutation and scaling MPS
iparm(13) = 0 ! maximum weighted matching algorithm is switched-off (default for symmetric). Try iparm(13) = 1 in case of inappropriate accuracy
iparm(14) = 0 ! Output: number of perturbed pivots
iparm(18) = 0!-1 ! Output: number of nonzeros in the factor LU
iparm(19) = 0!-1 ! Output: Mflops for LU factorization
iparm(20) = 0 ! Output: Numbers of CG Iterations

error  = 0 ! initialize error flag
msglvl = 0 ! print statistical information
mtype  = -2 ! symmetric, indefinite

!.. Initiliaze the internal solver memory pointer. This is only
! necessary for the FIRST call of the PARDISO solver.

ALLOCATE ( pt ( 64 ) )
do i = 1, 64
   pt( i )%DUMMY =  0
end do

!.. Reordering and Symbolic Factorization, This step also allocates
! all memory that is necessary for the factorization

phase = 11 ! only reordering and symbolic factorization

CALL pardiso (pt, maxfct, mnum, mtype, phase, n, a, ia, ja, &
idum, nrhs, iparm, msglvl, ddum, ddum, error)

!WRITE(*,*) 'Reordering completed ... '
!IF (error /= 0) THEN
!   WRITE(*,*) 'The following ERROR was detected: ', error
!   GOTO 1000
!END IF
!WRITE(*,*) 'Number of nonzeros in factors = ',iparm(18)
!WRITE(*,*) 'Number of factorization MFLOPS = ',iparm(19)

!.. Factorization.
phase = 22 ! only factorization
CALL pardiso (pt, maxfct, mnum, mtype, phase, n, a, ia, ja, &
idum, nrhs, iparm, msglvl, ddum, ddum, error)
!WRITE(*,*) 'Factorization completed ... '
!IF (error /= 0) THEN
!   WRITE(*,*) 'The following ERROR was detected: ', error
!   GOTO 1000
!ENDIF

!.. Back substitution and iterative refinement
iparm(8) = 2 ! max numbers of iterative refinement steps
phase = 33 ! only factorization
do i = 1, np
    do j= 1, np
      b((i-1)*np+j) = dx*dx*((Uon(i+1,j)-Uon(i,j))/dx+(Von(i,j+1)-Von(i,j))/dy)/dt
    enddo
end do

!do j=1,np
!    i=0
!    b(i*np+j) = b(i*np+j)-sin(2.0*pi*i*dx)*sin(2.0*pi*j*dx)
!enddo
!do i=1,np
!    j=0
!    b((i-1)*np+j+1) = b((i-1)*np+j+1)-sin(2.0*pi*i*dx)*sin(2.0*pi*j*dx)
!enddo
!do j=1,np
!    i=np+1
!    b((i-2)*np+j) = b((i-2)*np+j)-sin(2.0*pi*i*dx)*sin(2.0*pi*j*dx)
!enddo
!do i=1,np
!    j=np+1
!    b((i-1)*np+j-1) = b((i-1)*np+j-1)-sin(2.0*pi*i*dx)*sin(2.0*pi*j*dx)
!enddo

CALL pardiso (pt, maxfct, mnum, mtype, phase, n, a, ia, ja, &
idum, nrhs, iparm, msglvl, b, x, error)
!WRITE(*,*) 'Solve completed ... '
!IF (error /= 0) THEN
!   WRITE(*,*) 'The following ERROR was detected: ', error
!   GOTO 1000
!ENDIF
!WRITE(*,*) 'The solution of the system is '
do i = 1, np
    do j= 1, np
         p(i,j)=x((i-1)*np+j)
    enddo
END DO

!1000 CONTINUE
!.. Termination and release of memory
phase = -1 ! release internal memory
CALL pardiso (pt, maxfct, mnum, mtype, phase, n, ddum, idum, idum, &
idum, nrhs, iparm, msglvl, ddum, ddum, error1)

IF ( ALLOCATED( ia ) )      DEALLOCATE( ia )
IF ( ALLOCATED( ja ) )      DEALLOCATE( ja )
IF ( ALLOCATED( a ) )       DEALLOCATE( a )
IF ( ALLOCATED( b ) )       DEALLOCATE( b )
IF ( ALLOCATED( x ) )       DEALLOCATE( x )
IF ( ALLOCATED( iparm ) )   DEALLOCATE( iparm )

IF (error1 /= 0) THEN
   WRITE(*,*) 'The following ERROR on release stage was detected: ', error1
   STOP 1
ENDIF

END


* Selected portion of code taken from:
*    http://www.math.wsu.edu/faculty/genz/software/mvtdstpack.f
* to compute bivariate normal and Student's t distribution functions.
*
* Author:
*          Alan Genz
*          Department of Mathematics
*          Washington State University
*          Pullman, WA 99164-3113
*          Email : alangenz@wsu.edu
*
* except for some auxiliary functions whose authors are indicated
* in the respective code below.
*
*     "pbivnorm" subroutine, for calculating vectorized bivariate
*     normals, added by Brenton Kenkel, 2011-02-21.  based on a similar
*     subroutine by Adelchi Azzalini in the 'mnormt' package

      SUBROUTINE PBIVNORM(PROB, LOWER, UPPERA, UPPERB, INFIN,
     +     CORREL, LENGTH)
      DOUBLE PRECISION PROB(*), LOWER(*), UPPERA(*), UPPERB(*),
     +     CORREL(*)
      DOUBLE PRECISION THIS_UPPER(2), THIS_CORREL, MVBVN
      INTEGER INFIN(*), LENGTH
      DO I = 1, LENGTH, 1
         THIS_UPPER(1) = UPPERA(I)
         THIS_UPPER(2) = UPPERB(I)
         THIS_CORREL = CORREL(I)
         PROB(I) = MVBVN(LOWER, THIS_UPPER, INFIN, THIS_CORREL)
      END DO
      RETURN
      END

************************************************************************
*
      DOUBLE PRECISION FUNCTION MVBVN( LOWER, UPPER, INFIN, CORREL )
*
*     A function for computing bivariate normal probabilities.
*
*  Parameters
*
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, correlation coefficient.
*
      DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, MVBVU
      INTEGER INFIN(*)
      IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 2 ) THEN
         MVBVN =  MVBVU ( LOWER(1), LOWER(2), CORREL )
     +           - MVBVU ( UPPER(1), LOWER(2), CORREL )
     +           - MVBVU ( LOWER(1), UPPER(2), CORREL )
     +           + MVBVU ( UPPER(1), UPPER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 1 ) THEN
         MVBVN =  MVBVU ( LOWER(1), LOWER(2), CORREL )
     +           - MVBVU ( UPPER(1), LOWER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 2 ) THEN
         MVBVN =  MVBVU ( LOWER(1), LOWER(2), CORREL )
     +           - MVBVU ( LOWER(1), UPPER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 0 ) THEN
         MVBVN =  MVBVU ( -UPPER(1), -UPPER(2), CORREL )
     +           - MVBVU ( -LOWER(1), -UPPER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 2 ) THEN
         MVBVN =  MVBVU ( -UPPER(1), -UPPER(2), CORREL )
     +           - MVBVU ( -UPPER(1), -LOWER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 0 ) THEN
         MVBVN =  MVBVU ( LOWER(1), -UPPER(2), -CORREL )
      ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 1 ) THEN
         MVBVN =  MVBVU ( -UPPER(1), LOWER(2), -CORREL )
      ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 1 ) THEN
         MVBVN =  MVBVU ( LOWER(1), LOWER(2), CORREL )
      ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 0 ) THEN
         MVBVN =  MVBVU ( -UPPER(1), -UPPER(2), CORREL )
      ELSE
         MVBVN = 1
      END IF
      END
      DOUBLE PRECISION FUNCTION MVBVU( SH, SK, R )
*
*     A function for computing bivariate normal probabilities;
*       developed using
*         Drezner, Z. and Wesolowsky, G. O. (1989),
*         On the Computation of the Bivariate Normal Integral,
*         J. Stat. Comput. Simul.. 35 pp. 101-107.
*       with extensive modications for double precisions by
*         Alan Genz and Yihong Ge
*         Department of Mathematics
*         Washington State University
*         Pullman, WA 99164-3113
*         Email : alangenz@wsu.edu
*
* BVN - calculate the probability that X is larger than SH and Y is
*       larger than SK.
*
* Parameters
*
*   SH  REAL, integration limit
*   SK  REAL, integration limit
*   R   REAL, correlation coefficient
*   LG  INTEGER, number of Gauss Rule Points and Weights
*
      DOUBLE PRECISION BVN, SH, SK, R, ZERO, TWOPI
      INTEGER I, LG, NG
      PARAMETER ( ZERO = 0, TWOPI = 6.283185307179586D0 )
      DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS
      DOUBLE PRECISION MVPHI, SN, ASR, H, K, BS, HS, HK
      SAVE X, W
*     Gauss Legendre Points and Weights, N =  6
      DATA ( W(I,1), X(I,1), I = 1, 3 ) /
     *  0.1713244923791705D+00,-0.9324695142031522D+00,
     *  0.3607615730481384D+00,-0.6612093864662647D+00,
     *  0.4679139345726904D+00,-0.2386191860831970D+00/
*     Gauss Legendre Points and Weights, N = 12
      DATA ( W(I,2), X(I,2), I = 1, 6 ) /
     *  0.4717533638651177D-01,-0.9815606342467191D+00,
     *  0.1069393259953183D+00,-0.9041172563704750D+00,
     *  0.1600783285433464D+00,-0.7699026741943050D+00,
     *  0.2031674267230659D+00,-0.5873179542866171D+00,
     *  0.2334925365383547D+00,-0.3678314989981802D+00,
     *  0.2491470458134029D+00,-0.1252334085114692D+00/
*     Gauss Legendre Points and Weights, N = 20
      DATA ( W(I,3), X(I,3), I = 1, 10 ) /
     *  0.1761400713915212D-01,-0.9931285991850949D+00,
     *  0.4060142980038694D-01,-0.9639719272779138D+00,
     *  0.6267204833410906D-01,-0.9122344282513259D+00,
     *  0.8327674157670475D-01,-0.8391169718222188D+00,
     *  0.1019301198172404D+00,-0.7463319064601508D+00,
     *  0.1181945319615184D+00,-0.6360536807265150D+00,
     *  0.1316886384491766D+00,-0.5108670019508271D+00,
     *  0.1420961093183821D+00,-0.3737060887154196D+00,
     *  0.1491729864726037D+00,-0.2277858511416451D+00,
     *  0.1527533871307259D+00,-0.7652652113349733D-01/
      IF ( ABS(R) .LT. 0.3 ) THEN
         NG = 1
         LG = 3
      ELSE IF ( ABS(R) .LT. 0.75 ) THEN
         NG = 2
         LG = 6
      ELSE
         NG = 3
         LG = 10
      ENDIF
      H = SH
      K = SK
      HK = H*K
      BVN = 0
      IF ( ABS(R) .LT. 0.925 ) THEN
         HS = ( H*H + K*K )/2
         ASR = ASIN(R)
         DO I = 1, LG
            SN = SIN(ASR*( X(I,NG)+1 )/2)
            BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) )
            SN = SIN(ASR*(-X(I,NG)+1 )/2)
            BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) )
         END DO
         BVN = BVN*ASR/(2*TWOPI) + MVPHI(-H)*MVPHI(-K)
      ELSE
         IF ( R .LT. 0 ) THEN
            K = -K
            HK = -HK
         ENDIF
         IF ( ABS(R) .LT. 1 ) THEN
            AS = ( 1 - R )*( 1 + R )
            A = SQRT(AS)
            BS = ( H - K )**2
            C = ( 4 - HK )/8
            D = ( 12 - HK )/16
            BVN = A*EXP( -(BS/AS + HK)/2 )
     +             *( 1 - C*(BS - AS)*(1 - D*BS/5)/3 + C*D*AS*AS/5 )
            IF ( HK .GT. -160 ) THEN
               B = SQRT(BS)
               BVN = BVN - EXP(-HK/2)*SQRT(TWOPI)*MVPHI(-B/A)*B
     +                    *( 1 - C*BS*( 1 - D*BS/5 )/3 )
            ENDIF
            A = A/2
            DO I = 1, LG
               XS = ( A*(X(I,NG)+1) )**2
               RS = SQRT( 1 - XS )
               BVN = BVN + A*W(I,NG)*
     +              ( EXP( -BS/(2*XS) - HK/(1+RS) )/RS
     +              - EXP( -(BS/XS+HK)/2 )*( 1 + C*XS*( 1 + D*XS ) ) )
               XS = AS*(-X(I,NG)+1)**2/4
               RS = SQRT( 1 - XS )
               BVN = BVN + A*W(I,NG)*EXP( -(BS/XS + HK)/2 )
     +                    *( EXP( -HK*(1-RS)/(2*(1+RS)) )/RS
     +                       - ( 1 + C*XS*( 1 + D*XS ) ) )
            END DO
            BVN = -BVN/TWOPI
         ENDIF
         IF ( R .GT. 0 ) BVN =  BVN + MVPHI( -MAX( H, K ) )
         IF ( R .LT. 0 ) BVN = -BVN + MAX( ZERO, MVPHI(-H) - MVPHI(-K) )
      ENDIF
      MVBVU = BVN
      END
*
      DOUBLE PRECISION FUNCTION MVSTDT( NU, T )
*
*     Student t Distribution Function
*
*                       T
*         TSTDNT = C   I  ( 1 + y*y/NU )**( -(NU+1)/2 ) dy
*                   NU -INF
*
      INTEGER NU, J
      DOUBLE PRECISION MVPHI, T, CSTHE, SNTHE, POLYN, TT, TS, RN, PI
      PARAMETER ( PI = 3.141592653589793D0 )
      IF ( NU .LT. 1 ) THEN
         MVSTDT = MVPHI( T )
      ELSE IF ( NU .EQ. 1 ) THEN
         MVSTDT = ( 1 + 2*ATAN( T )/PI )/2
      ELSE IF ( NU .EQ. 2) THEN
         MVSTDT = ( 1 + T/SQRT( 2 + T*T ))/2
      ELSE
         TT = T*T
         CSTHE = NU/( NU + TT )
         POLYN = 1
         DO J = NU - 2, 2, -2
            POLYN = 1 + ( J - 1 )*CSTHE*POLYN/J
         END DO
         IF ( MOD( NU, 2 ) .EQ. 1 ) THEN
            RN = NU
            TS = T/SQRT(RN)
            MVSTDT = ( 1 + 2*( ATAN( TS ) + TS*CSTHE*POLYN )/PI )/2
         ELSE
            SNTHE = T/SQRT( NU + TT )
            MVSTDT = ( 1 + SNTHE*POLYN )/2
         END IF
         IF ( MVSTDT .LT. 0 ) MVSTDT = 0
      ENDIF
      END
*
      DOUBLE PRECISION FUNCTION MVBVT( NU, LOWER, UPPER, INFIN, CORREL )
*
*     A function for computing bivariate normal and t probabilities.
*
*  Parameters
*
*     NU     INTEGER degrees of freedom parameter; NU < 1 gives normal case.
*     LOWER  REAL, array of lower integration limits.
*     UPPER  REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
*            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
*            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
*     CORREL REAL, correlation coefficient.
*
      DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, MVBVN, MVBVTL
      INTEGER NU, INFIN(*)
      IF ( NU .LT. 1 ) THEN
            MVBVT =  MVBVN ( LOWER, UPPER, INFIN, CORREL )
      ELSE
         IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 2 ) THEN
            MVBVT =  MVBVTL ( NU, UPPER(1), UPPER(2), CORREL )
     +           - MVBVTL ( NU, UPPER(1), LOWER(2), CORREL )
     +           - MVBVTL ( NU, LOWER(1), UPPER(2), CORREL )
     +           + MVBVTL ( NU, LOWER(1), LOWER(2), CORREL )
         ELSE IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 1 ) THEN
            MVBVT =  MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL )
     +           - MVBVTL ( NU, -UPPER(1), -LOWER(2), CORREL )
         ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 2 ) THEN
            MVBVT =  MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL )
     +           - MVBVTL ( NU, -LOWER(1), -UPPER(2), CORREL )
         ELSE IF ( INFIN(1) .EQ. 2  .AND. INFIN(2) .EQ. 0 ) THEN
            MVBVT =  MVBVTL ( NU, UPPER(1), UPPER(2), CORREL )
     +           - MVBVTL ( NU, LOWER(1), UPPER(2), CORREL )
         ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 2 ) THEN
            MVBVT =  MVBVTL ( NU, UPPER(1), UPPER(2), CORREL )
     +           - MVBVTL ( NU, UPPER(1), LOWER(2), CORREL )
         ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 0 ) THEN
            MVBVT =  MVBVTL ( NU, -LOWER(1), UPPER(2), -CORREL )
         ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 1 ) THEN
            MVBVT =  MVBVTL ( NU, UPPER(1), -LOWER(2), -CORREL )
         ELSE IF ( INFIN(1) .EQ. 1  .AND. INFIN(2) .EQ. 1 ) THEN
            MVBVT =  MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL )
         ELSE IF ( INFIN(1) .EQ. 0  .AND. INFIN(2) .EQ. 0 ) THEN
            MVBVT =  MVBVTL ( NU, UPPER(1), UPPER(2), CORREL )
         ELSE
            MVBVT = 1
         END IF
      END IF
      END
*
      DOUBLE PRECISION FUNCTION MVBVTC( NU, L, U, INFIN, RHO )
*
*     A function for computing complementary bivariate normal and t
*       probabilities.
*
*  Parameters
*
*     NU     INTEGER degrees of freedom parameter.
*     L      REAL, array of lower integration limits.
*     U      REAL, array of upper integration limits.
*     INFIN  INTEGER, array of integration limits flags:
*            if INFIN(1) INFIN(2),        then MVBVTC computes
*                 0         0              P( X>U(1), Y>U(2) )
*                 1         0              P( X<L(1), Y>U(2) )
*                 0         1              P( X>U(1), Y<L(2) )
*                 1         1              P( X<L(1), Y<L(2) )
*                 2         0      P( X>U(1), Y>U(2) ) + P( X<L(1), Y>U(2) )
*                 2         1      P( X>U(1), Y<L(2) ) + P( X<L(1), Y<L(2) )
*                 0         2      P( X>U(1), Y>U(2) ) + P( X>U(1), Y<L(2) )
*                 1         2      P( X<L(1), Y>U(2) ) + P( X<L(1), Y<L(2) )
*                 2         2      P( X>U(1), Y<L(2) ) + P( X<L(1), Y<L(2) )
*                               +  P( X>U(1), Y>U(2) ) + P( X<L(1), Y>U(2) )
*
*     RHO    REAL, correlation coefficient.
*
      DOUBLE PRECISION L(*), U(*), LW(2), UP(2), B, RHO, MVBVT
      INTEGER I, NU, INFIN(*), INF(2)
*
      DO I = 1, 2
         IF ( MOD( INFIN(I), 2 ) .EQ. 0 ) THEN
            INF(I) = 1
            LW(I) = U(I)
         ELSE
            INF(I) = 0
            UP(I) = L(I)
         END IF
      END DO
      B = MVBVT( NU, LW, UP, INF, RHO )
      DO I = 1, 2
         IF ( INFIN(I) .EQ. 2 ) THEN
            INF(I) = 0
            UP(I) = L(I)
            B = B + MVBVT( NU, LW, UP, INF, RHO )
         END IF
      END DO
      IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN
         INF(1) = 1
         LW(1) = U(1)
         B = B + MVBVT( NU, LW, UP, INF, RHO )
      END IF
      MVBVTC = B
      END
*
      double precision function mvbvtl( nu, dh, dk, r )
*
*     a function for computing bivariate t probabilities.
*
*       Alan Genz
*       Department of Mathematics
*       Washington State University
*       Pullman, Wa 99164-3113
*       Email : alangenz@wsu.edu
*
*    this function is based on the method described by
*        Dunnett, C.W. and M. Sobel, (1954),
*        A bivariate generalization of Student's t-distribution
*        with tables for certain special cases,
*        Biometrika 41, pp. 153-169.
*
* mvbvtl - calculate the probability that x < dh and y < dk.
*
* parameters
*
*   nu number of degrees of freedom
*   dh 1st lower integration limit
*   dk 2nd lower integration limit
*   r   correlation coefficient
*
      integer nu, j, hs, ks
      double precision dh, dk, r
      double precision tpi, pi, ors, hrk, krh, bvt, snu
      double precision gmph, gmpk, xnkh, xnhk, qhrk, hkn, hpk, hkrn
      double precision btnckh, btnchk, btpdkh, btpdhk, one
      parameter ( pi = 3.14159265358979323844d0, tpi = 2*pi, one = 1 )
      snu = sqrt( dble(nu) )
      ors = 1 - r*r
      hrk = dh - r*dk
      krh = dk - r*dh
      if ( abs(hrk) + ors .gt. 0 ) then
         xnhk = hrk**2/( hrk**2 + ors*( nu + dk**2 ) )
         xnkh = krh**2/( krh**2 + ors*( nu + dh**2 ) )
      else
         xnhk = 0
         xnkh = 0
      end if
      hs = sign( one, dh - r*dk )
      ks = sign( one, dk - r*dh )
      if ( mod( nu, 2 ) .eq. 0 ) then
         bvt = atan2( sqrt(ors), -r )/tpi
         gmph = dh/sqrt( 16*( nu + dh**2 ) )
         gmpk = dk/sqrt( 16*( nu + dk**2 ) )
         btnckh = 2*atan2( sqrt( xnkh ), sqrt( 1 - xnkh ) )/pi
         btpdkh = 2*sqrt( xnkh*( 1 - xnkh ) )/pi
         btnchk = 2*atan2( sqrt( xnhk ), sqrt( 1 - xnhk ) )/pi
         btpdhk = 2*sqrt( xnhk*( 1 - xnhk ) )/pi
         do j = 1, nu/2
            bvt = bvt + gmph*( 1 + ks*btnckh )
            bvt = bvt + gmpk*( 1 + hs*btnchk )
            btnckh = btnckh + btpdkh
            btpdkh = 2*j*btpdkh*( 1 - xnkh )/( 2*j + 1 )
            btnchk = btnchk + btpdhk
            btpdhk = 2*j*btpdhk*( 1 - xnhk )/( 2*j + 1 )
            gmph = gmph*( 2*j - 1 )/( 2*j*( 1 + dh**2/nu ) )
            gmpk = gmpk*( 2*j - 1 )/( 2*j*( 1 + dk**2/nu ) )
         end do
      else
         qhrk = sqrt( dh**2 + dk**2 - 2*r*dh*dk + nu*ors )
         hkrn = dh*dk + r*nu
         hkn = dh*dk - nu
         hpk = dh + dk
         bvt = atan2(-snu*(hkn*qhrk+hpk*hkrn),hkn*hkrn-nu*hpk*qhrk)/tpi
         if ( bvt .lt. -1d-15 ) bvt = bvt + 1
         gmph = dh/( tpi*snu*( 1 + dh**2/nu ) )
         gmpk = dk/( tpi*snu*( 1 + dk**2/nu ) )
         btnckh = sqrt( xnkh )
         btpdkh = btnckh
         btnchk = sqrt( xnhk )
         btpdhk = btnchk
         do j = 1, ( nu - 1 )/2
            bvt = bvt + gmph*( 1 + ks*btnckh )
            bvt = bvt + gmpk*( 1 + hs*btnchk )
            btpdkh = ( 2*j - 1 )*btpdkh*( 1 - xnkh )/( 2*j )
            btnckh = btnckh + btpdkh
            btpdhk = ( 2*j - 1 )*btpdhk*( 1 - xnhk )/( 2*j )
            btnchk = btnchk + btpdhk
            gmph = 2*j*gmph/( ( 2*j + 1 )*( 1 + dh**2/nu ) )
            gmpk = 2*j*gmpk/( ( 2*j + 1 )*( 1 + dk**2/nu ) )
         end do
      end if
      mvbvtl = bvt
*
*     end mvbvtl
*
      end
*
*
      DOUBLE PRECISION FUNCTION MVPHI(Z)
*
*     Normal distribution probabilities accurate to 1d-15.
*     Reference: J.L. Schonfelder, Math Comp 32(1978), pp 1232-1240.
*
      INTEGER I, IM
      DOUBLE PRECISION A(0:43), BM, B, BP, P, RTWO, T, XA, Z
      PARAMETER( RTWO = 1.414213562373095048801688724209D0, IM = 24 )
      SAVE A
      DATA ( A(I), I = 0, 43 )/
     &    6.10143081923200417926465815756D-1,
     &   -4.34841272712577471828182820888D-1,
     &    1.76351193643605501125840298123D-1,
     &   -6.0710795609249414860051215825D-2,
     &    1.7712068995694114486147141191D-2,
     &   -4.321119385567293818599864968D-3,
     &    8.54216676887098678819832055D-4,
     &   -1.27155090609162742628893940D-4,
     &    1.1248167243671189468847072D-5, 3.13063885421820972630152D-7,
     &   -2.70988068537762022009086D-7, 3.0737622701407688440959D-8,
     &    2.515620384817622937314D-9, -1.028929921320319127590D-9,
     &    2.9944052119949939363D-11, 2.6051789687266936290D-11,
     &   -2.634839924171969386D-12, -6.43404509890636443D-13,
     &    1.12457401801663447D-13, 1.7281533389986098D-14,
     &   -4.264101694942375D-15, -5.45371977880191D-16,
     &    1.58697607761671D-16, 2.0899837844334D-17,
     &   -5.900526869409D-18, -9.41893387554D-19, 2.14977356470D-19,
     &    4.6660985008D-20, -7.243011862D-21, -2.387966824D-21,
     &    1.91177535D-22, 1.20482568D-22, -6.72377D-25, -5.747997D-24,
     &   -4.28493D-25, 2.44856D-25, 4.3793D-26, -8.151D-27, -3.089D-27,
     &    9.3D-29, 1.74D-28, 1.6D-29, -8.0D-30, -2.0D-30 /
*
      XA = ABS(Z)/RTWO
      IF ( XA .GT. 100 ) THEN
         P = 0
      ELSE
         T = ( 8*XA - 30 ) / ( 4*XA + 15 )
         BM = 0
         B  = 0
         DO I = IM, 0, -1
            BP = B
            B  = BM
            BM = T*B - BP  + A(I)
         END DO
         P = EXP( -XA*XA )*( BM - BP )/4
      END IF
      IF ( Z .GT. 0 ) P = 1 - P
      MVPHI = P
      END
*