! triangle - SAS configuration
!   input - the lengths of two sides and the measure of the subtended angle
!   output -
!       the sides and angles
!       the semiperimeter and the area
!       type of triangle

      program triangle
      print*,"SAS Congruence"

! Notes:
!   100 grad = 90 degrees = pi/2 (rad) = 1 rt angle = 1/4 rev
!   200 grad = 180 degrees = pi (rad) = 2 rt angles = 1/2 rev

      print*,"Angle measure units (1-radian, 2-degree, 3-grad, 4-rev):"
      read(*,*) imeas
      if(imeas .lt. 1 .or. imeas .gt. 4) then
          print*,"ERROR: unsupported angle measure"
          stop 1
      end if

      print*,"Enter the lengths of the two given sides (a and b):"
      read(*,*) a, b
      print*,"Enter the measure subtended angle (C):"
      read(*,*) gamm

! Error conditions
!   (1) the sides must be positive in length
      if(a.le.0.0 .or. b.le.0.0) then
          print*,"ERROR: The sides must be positive in length"
          stop 1
      end if
!   (2) the measure of the angle should be between 0 and pi
      pi = 4*atan(1.d0)
      if(imeas.eq.1) then       ! input in radians
          dgamma = 180 * gamm / pi
          ggamma = 200 * gamm / pi
          rgamma = gamm / (2 * pi)
      else if(imeas.eq.2) then  ! input in degrees
          dgamma = gamm
          gamm = pi * dgamma / 180
          ggamma = 200 * dgamma / 180
          rgamma = dgamma / 360
      else if(imeas.eq.3) then  ! input in grads
          ggamma = gamm
          gamm = pi * ggamma / 200
          dgamma = 180 * ggamma / 200
          rgamma = dgamma / 400
      else                      ! input in revolutions
          rgamma = gamm
          gamm = 2 * pi * ggamma
          dgamma = 360 * ggamma
          ggamma = 400 * rgamma
      end if
      if(gamm.le.0 .or. gamm .ge.pi) then
          print*, "ERROR: the given angle must be between 0 and 1/2 rev"
          stop 1
      end if

! finding the side opposite the given angle gives SSS and SSA
      c = sqrt(a*a + b*b - 2*a*b*cos(gamm))

! we could use law of sines but arcsin gives incorrect results if
! A or B is obtuse -- law of cosines has other numerical issues...
      alpha = acos((c*c + b*b - a*a) / (2*c*b))
      beta = acos((c*c + a*a - b*b) / (2*c*a))

! angles in degrees
      dalpha = 180 * alpha / pi
      dbeta = 180 * beta / pi

! angles in grads
      galpha = 200 * alpha / pi
      gbeta = 200 * beta / pi

! angles in revolutions
      ralpha = alpha / (2 * pi)
      rbeta = beta / (2 * pi)

! output solution of triangle
      print*,"------- SOLUTION ------------------------------------"
      write(6,*) "a =", a, "  (given)"
      write(6,*) "b =", b, "  (given)"
      write(6,*) "c =", c
      write(6,*) "A =", alpha, "degrees:", dalpha
      write(6,*) "B =", beta, "degrees:", dbeta
      write(6,*) "C =", gamm, "degrees:", dgamma, "  (given)"
      print*,"-----------------------------------------------------"
      print*,"Angles in grads:"
      write(6,*) "     ", galpha, gbeta, ggamma
      write(6,*) "     sum:", galpha + gbeta + ggamma, "  (exp: 200)"
      print*,"Angles in revolutions:"
      write(6,*) "     ", ralpha, rbeta, rgamma
      write(6,*) "     sum:", ralpha + rbeta + rgamma, "  (exp: 0.5)"
      print*,"-----------------------------------------------------"

! output semiperimeter and area
      s = (a + b + c) / 2
      write(6,*) "semiperimeter:", s
      area = sqrt(s * (s-a) * (s-b) * (s-c))    ! Heron's formula
      write(6,*) "area:", area

! angle sum
      sum1 = alpha + beta + gamm
      err1 = sum1 - pi
      sum2 = dalpha + dbeta + dgamma
      err2 = sum2 - 180.0
      write(6,*) "angle sum (radians):", sum1, "   error:", err1
      write(6,*) "angle sum (degrees):", sum2, "   error:", err2

! triangle inequality check:
!           a + b < c; b + c < a; c + a < c
! A sufficient and necessary condition is that no side may
! exceed the semiperimeter.
      if (max(a,b,c) .ge. s) then
          print*,"ERROR: (triangle inequality) max(a,b,c) < s"
      end if

! Nesbitt's inequality
      symsum = a/(b+c) + b/(a+c) + c/(a+b)
      print*,"Nesbitt's symmetric sum:", symsum
      if (symsum.lt.1.5) then
          print*,"   Error: sum < 1.5"
      end if
      if (symsum.ge.2) then
          print*,"   Error: sum > 2"
      end if

      end program


      PROGRAM xfour1
C     driver for routine four1
      INTEGER NN,NN2
      PARAMETER (NN=32,NN2=2*NN)
      REAL data(NN2),dcmp(NN2)
      INTEGER i,isign,j
      write(*,*) 'h(t)=real-valued even-function'
      write(*,*) 'H(n)=H(N-n) and real?'
      do 11 i=1,2*NN-1,2
        data(i)=1.0/(((i-NN-1.0)/NN)**2+1.0)
        data(i+1)=0.0
11    continue
      isign=1
      call four1(data,NN,isign)
      call prntft(data,NN2)
      write(*,*) 'h(t)=imaginary-valued even-function'
      write(*,*) 'H(n)=H(N-n) and imaginary?'
      do 12 i=1,2*NN-1,2
        data(i+1)=1.0/(((i-NN-1.0)/NN)**2+1.0)
        data(i)=0.0
12    continue
      isign=1
      call four1(data,NN,isign)
      call prntft(data,NN2)
      write(*,*) 'h(t)=real-valued odd-function'
      write(*,*) 'H(n)=-H(N-n) and imaginary?'
      do 13 i=1,2*NN-1,2
        data(i)=(i-NN-1.0)/NN/(((i-NN-1.0)/NN)**2+1.0)
        data(i+1)=0.0
13    continue
      data(1)=0.0
      isign=1
      call four1(data,NN,isign)
      call prntft(data,NN2)
      write(*,*) 'h(t)=imaginary-valued odd-function'
      write(*,*) 'H(n)=-H(N-n) and real?'
      do 14 i=1,2*NN-1,2
        data(i+1)=(i-NN-1.0)/NN/(((i-NN-1.0)/NN)**2+1.0)
        data(i)=0.0
14    continue
      data(2)=0.0
      isign=1
      call four1(data,NN,isign)
      call prntft(data,NN2)
C     transform, inverse-transform test
      do 15 i=1,2*NN-1,2
        data(i)=1.0/((0.5*(i-NN-1)/NN)**2+1.0)
        dcmp(i)=data(i)
        data(i+1)=(0.25*(i-NN-1)/NN)*
     *       exp(-(0.5*(i-NN-1.0)/NN)**2)
        dcmp(i+1)=data(i+1)
15    continue
      isign=1
      call four1(data,NN,isign)
      isign=-1
      call four1(data,NN,isign)
      write(*,'(/1x,t10,a,t44,a)') 'Original Data:',
     *     'Double Fourier Transform:'
      write(*,'(/1x,t5,a,t11,a,t24,a,t41,a,t53,a/)')
     *     'k','Real h(k)','Imag h(k)','Real h(k)','Imag h(k)'
      do 16 i=1,NN,2
        j=(i+1)/2
        write(*,'(1x,i4,2x,2f12.6,5x,2f12.6)') j,dcmp(i),
     *       dcmp(i+1),data(i)/NN,data(i+1)/NN
16    continue
      END
      SUBROUTINE prntft(data,nn2)
      INTEGER n,nn2,m,mm
      REAL data(nn2)
      write(*,'(/1x,t5,a,t11,a,t23,a,t39,a,t52,a)')
     *     'n','Real H(n)','Imag H(n)','Real H(N-n)','Imag H(N-n)'
      write(*,'(1x,i4,2x,2f12.6,5x,2f12.6)') 0,data(1),data(2),
     *     data(1),data(2)
      do 11 n=3,(nn2/2)+1,2
        m=(n-1)/2
        mm=nn2+2-n
        write(*,'(1x,i4,2x,2f12.6,5x,2f12.6)') m,data(n),
     *       data(n+1),data(mm),data(mm+1)
11    continue
      write(*,'(/1x,a)') ' press RETURN to continue ...'
      read(*,*)
      return
      END

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


MODULE basis_functions_m

	IMPLICIT NONE

	CHARACTER(len = 20) :: u_fns_name		! kind of u basis functions to use.  select one of:
											! "polynomial_u", "Max_poly_u", or "B_spline_u"

	REAL :: u0_Max_poly	! Width of Maxwellian used in Max_poly_u_basis

CONTAINS

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

SUBROUTINE u_basis(u, n_g, g, dg_du)

! Evaluates the g(u) basis functions (n_g of them) at argument u

	IMPLICIT NONE

	REAL, INTENT(in) :: u
	INTEGER, INTENT(in) :: n_g
	REAL, INTENT(out) :: g(n_g)
	REAL, OPTIONAL, INTENT(out) :: dg_du(n_g)

	SELECT CASE (TRIM(u_fns_name))

		CASE ("polynomial_u")
			CALL polynomial_u_basis(u, n_g, g, dg_du)
		CASE ("Max_poly_u")
			CALL Max_poly_u_basis(u, n_g, g)
		CASE ("B_spline_u")
			CALL cubic_B_spline_basis(u, n_g, g, dg_du)
		CASE DEFAULT
			WRITE(*,*) "Unimplemented u basis = ", u_fns_name
			STOP

	END SELECT
!              write(6, *) "dg_du = "
!              write(6, *) dg_du
	RETURN

END SUBROUTINE u_basis

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

SUBROUTINE polynomial_u_basis(u, n_g, g, dg_du)

! Generates powers of u, u**n where n ranges from 0 to n_g - 1

	IMPLICIT NONE

	REAL, INTENT(in) :: u
	INTEGER, INTENT(in) :: n_g
	REAL, INTENT(out) :: g(n_g)
	REAL, OPTIONAL, INTENT(out) :: dg_du(n_g)

	INTEGER :: i

	g(1) = 1.

	DO i = 2, n_g
		g(i) = u * g(i-1)
	END DO

	IF (.not.PRESENT(dg_du))	RETURN

! Derivatives

	DO i = 1, n_g
		dg_du(i) = (i-1) * g(i-1)
	END DO

END SUBROUTINE polynomial_u_basis

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

SUBROUTINE Max_poly_u_basis(u, n_g, g)

! Generates powers of u times a Gaussian of width u_th

	IMPLICIT NONE

	REAL, INTENT(in) :: u
	INTEGER, INTENT(in) :: n_g
	REAL, INTENT(out) :: g(n_g)
	REAL :: Max_factor

	INTEGER :: i

	g(1) = 1.

	DO i = 2, n_g
		g(i) = u * g(i-1)
	END DO

	Max_factor = EXP(-u**2/u0_Max_poly**2)

	g = g * Max_factor

	RETURN

END SUBROUTINE Max_poly_u_basis

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

SUBROUTINE cos_theta_basis(theta, n_cosn, cosn, dcosn_dtheta)

! Generates cos(n * theta) where n ranges from 0 to n_g-1

	IMPLICIT NONE

	REAL, INTENT(in) :: theta
	INTEGER, INTENT(in) :: n_cosn
	REAL, INTENT(out) :: cosn(n_cosn)
	REAL, OPTIONAL, INTENT(out) :: dcosn_dtheta(n_cosn)

	INTEGER :: i

	cosn(1) = 1.

	DO i = 2, n_cosn
		cosn(i) = COS((i-1) * theta)
	END DO

	IF (.not.PRESENT(dcosn_dtheta))	RETURN

	dcosn_dtheta(1) = 0.

	DO i = 2, n_cosn
		dcosn_dtheta(i) = -(i-1)*SIN((i-1) * theta)
	END DO

	RETURN

END SUBROUTINE cos_theta_basis

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

END MODULE basis_functions_m


MODULE trend_line
IMPLICIT NONE
INTEGER, SAVE :: n
REAL, DIMENSION(:), ALLOCATABLE :: x_sum
REAL, DIMENSION(:), ALLOCATABLE :: xy_sum
!LOGICAL :: initialized = .FALSE.
CONTAINS
  SUBROUTINE cumul_trend_sums(x, y, k)
  IMPLICIT NONE
  REAL, INTENT(IN) :: x, y
  INTEGER, INTENT(IN) :: k
  INTEGER :: i

  IF (.not. ALLOCATED(x_sum) .and. .not. ALLOCATED(xy_sum)) THEN
    ALLOCATE(x_sum(0:2*n),xy_sum(0:n))
  END IF

  IF (k == 1) THEN
    x_sum = 0.
    xy_sum = 0.
  END IF

  DO i = 0, 2 * n
    x_sum(i) = x_sum(i) + x**i
  END DO
  DO i = 0, n
    xy_sum(i) = xy_sum(i) + (x**i) * y
  END DO
  END SUBROUTINE cumul_trend_sums

  SUBROUTINE build_matrix(a, b)
  REAL, DIMENSION(n,n), INTENT(OUT) :: a
  REAL, DIMENSION(n), INTENT(OUT) :: b
  INTEGER :: i, j, k

  DO i = 1, n + 1
    DO j = 1, n + 1
      k = i + j - 2
      a(i, j) = x_sum(k)
    END DO
  END DO
  b = xy_sum
  END SUBROUTINE build_matrix
END MODULE trend_line

SUBROUTINE simul(a, b, ndim, n, error)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ndim
REAL, INTENT(INOUT), DIMENSION(ndim, ndim) :: a
REAL, INTENT(INOUT), DIMENSION(ndim) :: b
INTEGER, INTENT(IN) :: n
INTEGER, INTENT(OUT) :: error
REAL, PARAMETER :: EPSILON = 1.0E-6
REAL :: factor, temp
INTEGER :: irow, ipeak, jrow, kcol

! Process n times to get all equations...
mainloop: DO irow = 1, n
  ! Find peak pivot for column irow in rows irow to n
  ipeak = irow
  max_pivot: DO jrow = irow + 1, n
    IF (ABS(a(jrow,irow)) > ABS(a(ipeak,irow))) THEN
      ipeak = jrow
    END IF
  END DO max_pivot

  ! Check for singular equations.
  singular: IF(ABS(a(ipeak,irow)) < EPSILON) THEN
    error = 1
    RETURN
  END IF singular

  ! Otherwise, if ipeak /= irow, swap equations irow & ipeak
  swap_eqn: IF (ipeak /= irow) THEN
    DO kcol = 1, n
      temp           = a(ipeak, kcol)
      a(ipeak, kcol) = a(irow, kcol)
      a(irow, kcol)  = temp
    END DO
    temp     = b(ipeak)
    b(ipeak) = b(irow)
    b(irow)  = temp
  END IF swap_eqn

  ! Multiply equation irow by -a(jrow, irow)/a(irow, irow)
  ! and add it to eqn jrow (for all eqns except irow itself).
  eliminate: DO jrow = 1, n
    IF (jrow /= irow) THEN
      factor = -a(jrow, irow) / a(irow, irow)
      DO kcol = 1, n
        a(jrow, kcol) = a(irow, kcol) * factor + a(jrow, kcol)
      END DO
      b(jrow) = b(irow) * factor + b(jrow)
    END IF
  END DO eliminate
END DO mainloop

divide: DO irow = 1, n
  b(irow)       = b(irow) / a(irow, irow)
  a(irow, irow) = 1
END DO divide

! Set error flag to 0 and return
error = 0
END SUBROUTINE simul

PROGRAM higher_ord
USE trend_line
IMPLICIT NONE
INTEGER, PARAMETER :: MAX_SIZE = 1000
REAL, DIMENSION(3, 3) :: a
REAL, DIMENSION(3) :: b
REAL :: x, y
INTEGER :: error
CHARACTER(len=20) :: file_name
INTEGER :: i, j, istat
CHARACTER(len=80) :: msg

WRITE(*, "('Enter the file name containing the data:')")
READ(*, '(A20)') file_name

! Open input data file. Status is OLD because the input data must
! already exist.
OPEN (UNIT=1, FILE=file_name, STATUS='OLD', ACTION='READ', &
      IOSTAT=istat, IOMSG=msg)

! Was the OPEN successful?
fileopen: IF(istat == 0) THEN
  ! The file was opened successfully, so read the number of
  ! measurements in the file.
  READ(1, *) n
  ! If the number of equ is <= MAX_SIZE, read them in
  ! and process them.
  size_ok: IF (n <= MAX_SIZE) THEN
    DO i = 1, n
      READ(1, *) x, y
      CALL cumul_trend_sums(x, y, i)
    END DO
    CALL build_matrix(a, b)
    ! Display coefficients.
    WRITE(*, "(/,'Coefficients before call:')")
    DO i = 1, 3
      WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, 3), b(i)
    END DO

    ! Solve equations
    CALL simul(a, b, 3, 3, error)

    ! Check for error.
    error_check: IF (error /= 0) THEN
      WRITE(*, 1010)
      1010 FORMAT(/'Zero pivot encountered!', &
                  //'There is no unique solution to this system.')
    ELSE error_check
      ! No errors. Display coefficients.
      WRITE(*, "(/,'Coefficients after call:')")
      DO i = 1, 3
        WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, 3), b(i)
      END DO
      ! Write the final answer.
      WRITE(*, "(/,'The solutions are:')")
      DO i = 1, 3
        WRITE(*,"(2X,'X(',I2,') = ',F16.6)") i, b(i)
      END DO
    END IF error_check
  END IF size_ok
ELSE fileopen
  ! Else file open failed. Tell user.
  WRITE(*, 1020) msg
  1020 FORMAT('File open failed: ', A)
END IF fileopen

END PROGRAM higher_ord


module approx_norm

    implicit none
    integer :: nsamples, seed
    save

contains

    subroutine approx_norm1(a, anorm)

    use omp_lib
    implicit none
    real(kind=8), dimension(:,:), intent(in) :: a
    real(kind=8), intent(out) :: anorm

    real(kind=8), allocatable, dimension(:) :: x,ax,allx
    integer :: i,j,k,n,k1,k2
    integer :: kstart,kend,thread_num,nthreads,samples_per_thread
    real(kind=8) :: xnorm, axnorm, ratio, max_ratio, max_ratio_thread

    n = size(a,1)
    allocate(x(n),ax(n))

    ! generate all the random numbers we'll ever need:
    allocate(allx(n*nsamples))
    call random_number(allx)

    max_ratio = 0.d0

    !$omp parallel private(i,j,max_ratio_thread,x,ax,xnorm,axnorm, &
    !$omp                  kstart,kend,thread_num,samples_per_thread)

    thread_num = 0     ! needed in serial mode
    !$ thread_num = omp_get_thread_num()    ! unique for each thread

    nthreads = 1  ! needed in serial mode
    !$ nthreads = omp_get_num_threads()
    samples_per_thread = (nsamples + nthreads - 1) / nthreads

    ! Determine start and end index for the set of samples to be
    ! handled by this thread:
    kstart = thread_num * samples_per_thread + 1
    kend = min((thread_num+1) * samples_per_thread, nsamples)

    !$omp critical
    print 201, thread_num, kstart, kend
    !$omp end critical
201 format("Thread ",i2," will take k = ",i6," through k = ",i6)

    max_ratio_thread = 0.d0

    do k=kstart,kend

        ! choose a random vector x by taking n elements from allx :
        k1 = (k-1)*n+1
        k2 = k*n
        x = allx(k1:k2)

        ! compute matrix-vector product ax:
        do i=1,n
            ax(i) = 0.d0
            do j=1,n
                ax(i) = ax(i) + a(i,j)*x(j)
                enddo
            enddo

        ! compute 1-norm of x and ax
        xnorm = 0.d0
        axnorm = 0.d0
        do i=1,n
            xnorm = xnorm + abs(x(i))
            axnorm = axnorm + abs(ax(i))
            enddo

        ratio = axnorm/xnorm
        max_ratio_thread = max(max_ratio_thread, ratio)
        enddo

    ! update global max_ratio with value from each thread:
    !$omp critical
      max_ratio = max(max_ratio, max_ratio_thread)
    !$omp end critical

    !$omp end parallel

    anorm = max_ratio

end subroutine approx_norm1

end module approx_norm


program nbody_direct
    implicit none
    real, parameter :: SOFTENING_SQR = 1.0e+4 * epsilon(0.0)
    real :: current ! current time
    real :: total   ! total time
    real :: step    ! integration time step
    real :: timer   ! cyclic time count to output results
    real :: lap     ! time cycle to output results
    integer :: n    ! number of bodies
    integer :: i, j
    real, allocatable :: m(:), r(:, :), v(:, :), a(:, :)
    real :: r_ij(2), a_i(2), a_ij(2)

    read *, step
    read *, lap
    read *, total
    read *, n
    allocate(m(n), r(2, n), v(2, n), a(2, n))
    do i = 1, n
        read *, m(i), r(:, i), v(:, i)
    end do

    ! Get the unknown accelerations.
    do i = 1, n
        a_i(:) = 0.0
        do j = 1, n
            if (j == i) cycle
            r_ij(:) = r(:, j) - r(:, i)
            a_ij(:) = (m(j) / norm2(r_ij)**3) * r_ij(:)
            a_i(:) = a_i(:) + a_ij(:)
        end do
        a(:, i) = a_i(:)
    end do

    ! Print the number of bodies.
    print *, n

    ! Start iterations.
    current = 0.0
    timer   = lap
    time: do while (current <= total)
        ! If the timer has elapsed, then print the current coordinates and
        ! re-set the timer.
        if (timer <= 0.0) then
            do i = 1, n
                print *, r(:, i)
            end do
            timer = timer + lap
        end if
        ! Half-kick velocities.
        v(:, :) = v(:, :) + (0.5 * step) * a(:, :)
        ! Drift coordinates.
        r(:, :) = r(:, :) + step * v(:, :)
        ! Update accelerations.
        do i = 1, n
            a_i(:) = 0.0
            do j = 1, n
                if (j == i) cycle
                r_ij(:) = r(:, j) - r(:, i)
                a_ij(:) = (m(j) / norm2(r_ij)**3) * r_ij(:)
                a_i(:) = a_i(:) + a_ij(:)
            end do
            a(:, i) = a_i(:)
        end do
        ! Half-kick velocities.
        v(:, :) = v(:, :) + (0.5 * step) * a(:, :)
        current = current + step
        timer   = timer   - step
    end do time

    deallocate(m, r, v, a)
end program nbody_direct


subroutine meanmax
use fdeclarations

implicit none
!Defuzzification according to the mean-max method

do i=1,z
hs(i)=max(high(i),good(i),moderate(i),poor(i),bad(i))
if (hs(i)>0) then

if (hs(i)==high(i)) then
x1high(i)=high(i)*hm-high(i)*ha+ha
x2high(i)=hb-high(i)*hb+high(i)*hm
aa(i,zz)=((x1high(i)+x2high(i))/2)/5
else if (hs(i)==good(i)) then
x1good(i)=good(i)*gm-good(i)*ga+ga
x2good(i)=gb-good(i)*gb+good(i)*gm
aa(i,zz)=((x1good(i)+x2good(i))/2)/5
else if (hs(i)==moderate(i)) then
x1mod(i)=moderate(i)*mm-moderate(i)*ma+ma
x2mod(i)=mb-moderate(i)*mb+moderate(i)*mm
aa(i,zz)=((x1mod(i)+x2mod(i))/2)/5
else if (hs(i)==poor(i)) then
x1poor(i)=poor(i)*pm-poor(i)*pa+pa
x2poor(i)=pb-poor(i)*pb+poor(i)*pm
aa(i,zz)=((x1poor(i)+x2poor(i))/2)/5
else
x1bad(i)=bad(i)*bm-bad(i)*ba+ba
x2bad(i)=bb-bad(i)*bb+bad(i)*bm
aa(i,zz)=((x1bad(i)+x2bad(i))/2)/5
end if
else
aa(i,zz)=aa(i-1,zz)
end if
end do

do i=1,z
if (l==1) then
suitability(i,zz)=aa(i,zz)
else if (l==2) then
s(i,zz)=aa(i,zz)
end if
end do

end subroutine meanmax


 FUNCTION PM_spectrum(FREQ, Hs, Tp)
!
! This function returns the value of the Pierson-Moskowitz spectrum
! for the frequency FREQ, significant wave height Hs, and peak period
! Tp.

   IMPLICIT none
   integer, parameter :: long=selected_real_kind(12,99)
   REAL(kind=long) :: pm_spectrum, Hs, Tp, A, B, freq, T02,   &
        four=4._long, pi, zero=0._long, one=1._long
   pi = acos (-one)

   T02=.71*Tp
   A = Hs*Hs/(four*pi*T02**4)
   B = one/(pi*T02**4)
   IF (freq.le.zero) then
      pm_spectrum = zero
   ELSE
      pm_spectrum = A/freq**5 * exp (-B/freq**4)
   ENDIF
   RETURN
 END FUNCTION PM_spectrum


subroutine parratt_born(q,lambda,d,rho,beta,sigma,Rgen,Rgenr, M,N)
!***************************************************************************
!Subroutine to calculate Specular Reflectivity using Parrat Algorithm with
!Born Approximation for roughness
!M = No. of data points
!N = No. of slabs
!lambda = wavelength
!d = list of thicknesses of each slab
!rho=list of Electron densities of each slab
!beta=list of Absorption coefficient in each slab
!Rgen = generated reflectivtiy data
!Rgenr = generated reflectance data
!q = change in wave vector
!***************************************************************************
integer :: M,N
double precision :: q(0:M), Rgen(0:M)
double precision :: d(0:N+1), rho(0:N+1), beta(0:N+1), sigma(0:N+1), qc2(0:N+1)
double precision :: lambda
double complex :: X, fact1, fact2, r(0:N+1), k1, k2, fact, Rgenr(0:M)
double precision, parameter :: re=2.814e-5, pi=3.14157

do j=0,N+1
   qc2(j)=16.0d0*pi*re*(rho(j)-rho(0))
enddo

do i = 0,M
   r(N+1)=dcmplx(0.0d0,0.0d0)
   do j=N,0,-1
      k1=cdsqrt(dcmplx(q(i)**2-qc2(j),-32.0d0*beta(j)*pi**2/lambda**2))
      k2=cdsqrt(dcmplx(q(i)**2-qc2(j+1),-32.0d0*beta(j+1)*pi**2/lambda**2))
      X=(k1-k2)*cdexp(-k1*k2*sigma(j+1)**2/2)/(k1+k2)
      fact1=dcmplx(dcos(dble(k2)*d(j+1)),dsin(dble(k2)*d(j+1)))
      fact2=dexp(-aimag(k2)*d(j+1))
      fact=fact1*fact2
      r(j)=(X+r(j+1)*fact)/(1.0+X*r(j+1)*fact)
   enddo
   Rgenr(i)=r(0)
   Rgen(i)=cdabs(r(0))**2
enddo
end subroutine parratt_born

subroutine parratt(q,lambda,d,rho,beta,Rgen,Rgenr,M,N)
!***************************************************************************
!Calculation of reflectivity by Parratt Recursion Formula without any roughness
!
!M = No. of data points
!N = No. of slabs
!lambda = wavelength
!d = list of thicknesses of each slab
!rho=list of Electron densities of each slab
!beta=list of Absorption coefficient in each slab
!Rgen = generated reflectivtiy data
!Rgenr= generated reflectance data
!q = change in wave vector
!***************************************************************************
integer :: M,N
double precision :: q(0:M), Rgen(0:M)
double precision :: d(0:N+1), rho(0:N+1), beta(0:N+1), qc2(0:N+1)
double precision :: lambda
double complex :: X, fact1, fact2, r(0:N+1), k1, k2, fact,Rgenr(0:M)
double precision, parameter :: re=2.814e-5, pi=3.14157

do j=0,N+1
   qc2(j)=16.0d0*pi*re*(rho(j)-rho(0))
enddo

do i = 0,M
   r(N+1)=dcmplx(0.0d0,0.0d0)
   do j=N,0,-1
      k1=cdsqrt(dcmplx(q(i)**2-qc2(j),-32.0d0*beta(j)*pi**2/lambda**2))
      k2=cdsqrt(dcmplx(q(i)**2-qc2(j+1),-32.0d0*beta(j+1)*pi**2/lambda**2))
      X=(k1-k2)/(k1+k2)
      fact1=dcmplx(dcos(dble(k2)*d(j+1)),dsin(dble(k2)*d(j+1)))
      fact2=dexp(-aimag(k2)*d(j+1))
      fact=fact1*fact2
      r(j)=(X+r(j+1)*fact)/(1.0+X*r(j+1)*fact)
   enddo
   Rgenr(i)=r(0)
   Rgen(i)=cdabs(r(0))**2
enddo
end subroutine parratt

subroutine conv_parratt(q,delq,lambda,d,rho,beta,Rgen,M,N)
!***************************************************************************
!Calculation of convoluted reflectivity by Parratt Recursion Formula without
!any roughness

!M = No. of data points
!N = No. of slabs
!lambda = wavelength
!d = list of thicknesses of each slab
!rho=list of Electron densities of each slab
!beta=list of Absorption coefficient in each slab
!Rgen = generated reflectivtiy data
!q = change in wave vector
!delq=width of the resolution funciton
!***************************************************************************
integer :: M,N
double precision :: q(0:M), Rgen(0:M)
double precision :: d(0:N+1), rho(0:N+1), beta(0:N+1), qc2(0:N+1)
double precision :: lambda,delq
double complex :: X, fact1, fact2, r(0:N+1), k1, k2, fact
double precision, parameter :: re=2.814e-5, pi=3.14157
double precision :: refsum,q0
integer :: Nres
Nres=21

do j=0,N+1
   qc2(j)=16.0d0*pi*re*(rho(j)-rho(0))
enddo

do i = 0,M
  r(N+1)=dcmplx(0.0d0,0.0d0)
  refsum=0.0d0
  ressum=0.0d0
  do k = -(Nres-1)/2,(Nres-1)/2
    qo=q(i)+4*k*delq/(Nres-1)
      if (qo>=0.0d0) then
	do j=N,0,-1
	  k1=cdsqrt(dcmplx(qo**2-qc2(j),-32.0d0*beta(j)*pi**2/lambda**2))
	  k2=cdsqrt(dcmplx(qo**2-qc2(j+1),-32.0d0*beta(j+1)*pi**2/lambda**2))
	  X=(k1-k2)/(k1+k2)
	  fact1=dcmplx(dcos(dble(k2)*d(j+1)),dsin(dble(k2)*d(j+1)))
	  fact2=dexp(-aimag(k2)*d(j+1))
	  fact=fact1*fact2
	  r(j)=(X+r(j+1)*fact)/(1.0+X*r(j+1)*fact)
        enddo
	refsum=refsum+cdabs(r(0))**2*dexp(-k**2/2.0d0/(Nres-1)**2)
	ressum=ressum+dexp(-dfloat(k)**2/2.0d0/(dfloat(Nres)-1)**2)
      endif
    enddo
    rgen(i)=refsum/ressum
enddo

end subroutine conv_parratt


      subroutine lagrange(x, xi, yi, ans)

C  GCM2.0  Feb 2003
C
C  Lagrange interpolation - Polynomial interpolation at point x
C  xi(1) <= x <= xi(4).  Yi(n) is the functional value at XI(n).

      implicit none

      real*8 x, xi(4), yi(4), ans
      real*8 fm1, fm2, fm3, fm4

C======================================================================!

      fm1   = x - XI(1)
      fm2   = x - XI(2)
      fm3   = x - XI(3)
      fm4   = x - XI(4)

C  Get the "answer" at the requested X

      ans = fm2*fm3*fm4*YI(1)/
     *                ((XI(1)-XI(2))*(XI(1)-XI(3))*(XI(1)-XI(4)))  +
     *      fm1*fm3*fm4*YI(2)/
     *                ((XI(2)-XI(1))*(XI(2)-XI(3))*(XI(2)-XI(4)))  +
     *      fm1*fm2*fm4*YI(3)/
     *                ((XI(3)-XI(1))*(XI(3)-XI(2))*(XI(3)-XI(4)))  +
     *      fm1*fm2*fm3*YI(4)/
     *                ((XI(4)-XI(1))*(XI(4)-XI(2))*(XI(4)-XI(3)))

      return
      end


res = covariance(x,y)/stdev(x)/stdev(y)


       SUBROUTINE RK(DT,F0,F,N,T,RPAR)
       IMPLICIT NONE
       DOUBLE PRECISION RPAR(10),HBAR,DT,T
       INTEGER I,N,J
       COMPLEX*8 F(N),F0(N),F1(N),F2(N),F3(N),F4(N)
       COMPLEX*8 F10(N),F20(N),F30(N),F40(N),H2(N,N)
       COMPLEX*8 :: eye
       COMPLEX*8 H(N,N)
        HBAR=0.6582D0   !PLANCK'S CONSTANT IN eV*fs
       eye = (0.0d0,1.0d0)                     !IMAGINARY NUMBER

       CALL HH(N,T,H,RPAR)
       H2=H
       F1=-eye*MATMUL(H2,F0)/HBAR

       F20=0.0D0
          DO J=1,N
           F20(J)=F0(J)+(F1(J)*DT)/2.0
          END DO

       CALL HH(N,T+DT/2.0,H,RPAR)

       H2=H
       F2=-eye*MATMUL(H2,F20)/HBAR

       F30=0.0D0
          DO J=1,N
           F30(J)=F0(J)+(F2(J)*DT)/2.0
          END DO

       CALL HH(N,T+DT/2.0,H,RPAR)

       H2=H
       F3=-eye*MATMUL(H2,F30)/HBAR

       F40=0.0D0
          DO J=1,N
           F40(J)=F0(J)+(F3(J)*DT)
          END DO

       CALL HH(N,T+DT,H,RPAR)
       H2=H
       F4=-eye*MATMUL(H2,F40)/HBAR

       F=0.0D0
          DO J=1,N
            F(J)=F0(J)+(DT/6.0)*(F1(J)+F4(J)+2.0*(F3(J)+F2(J)))
          END DO

       RETURN
       END


!-----------------------------------------------------------------------
subroutine transform(N,x,xmin,xmax,convert,y)
use Interface_MOD, only : NO
implicit none

integer, intent(in)       :: N

! Input vector can be original values or need to be converted back
real, intent(in)          :: x(N)

! The minimal allowed positive values in x, to avoid zero or negative values
! These values are normal values before transformation
real, intent(in)          :: xmin,xmax

! Whether to lognorm or convert back to normal values
integer, intent(in)       :: convert

real, intent(out)         :: y(N)

real :: max_y,min_y

integer :: i

! Normalization occurs after sqrt(sqrt(x)))  !
min_y = sqrt(sqrt(xmin))
max_y = sqrt(sqrt(xmax))

if (convert .eq. NO) then
   do i = 1, N
      y(i) = sqrt(sqrt(x(i)))
      y(i) = (y(i)-min_y)/(max_y-min_y)
   enddo
else
   do i = 1, N
      y(i) = x(i)*(max_y-min_y) + min_y
      y(i) = y(i)**4
   enddo
endif
end subroutine transform


subroutine PlON_d1(p, dp, lmax, z)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function evalutates all of the "ortho-normalized legendre
!	polynomials, as well as their first derivatives,  up to degree lmax.
!
!	Calling Parameters:
!		Out
!			p:	A vector of all normalized Legendgre polynomials evaluated at
!				z up to lmax with dimension (lmax+1).
!			dp:	A vector of all first derivatives of the normalized Legendgre polynomials evaluated at
!				z up to lmax with dimension (lmax+1).
!		IN
!			lmax:	Maximum degree to compute.
!			z:	[-1, 1], cos(colatitude), or sin(latitude).
!
!	Notes:
!
!	1.	The employed normalization is the "orthonomalization convention."
!	2.	The integral of PlBar**2 over all space on the sphere is 1.
!	3.	The integral of PlBar**2 over (-1,1) is 1/2pi.
!	4. 	The derivative is evaluated with respecte to z, and NOT cos(colatitude) or sin(latitude).
!	5.	Derivatives are calculated according to the geodesy-normalized relationships
!			P'_0(z) = 0.0, P'_1(z) = 1.0, and
!			P'_l(z) = l * (P_{l-1}(z) - z * P_l(z) ) / (1.0d0 - z**2)
!			At z = 1, Pl(1) = 1, and P'l(1) = l (l+1) / 2 	(Boyd 2001)
!			At z = -1 Pl(-1) = (-1)**l, and P'l(-1) = (-1)**(l-1) l (l+1) / 2
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek June 2004
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	lmax
	real*8, intent(out) ::	p(:), dp(:)
       	real*8, intent(in) ::	z
       	real*8 ::	pm2, pm1, pl, sinsq, pi
      	integer ::	l

	pi = acos(-1.0d0)

	if (size(p) < lmax+1) then
		print*, "Error --- PlBar_d1"
     		print*, "P must be dimensioned as (LMAX+1) where LMAX is ", lmax
     		print*, "Input array is dimensioned ", size(p)
     		stop
     	elseif (size(dp) < lmax+1) then
		print*, "Error --- PlBar_d1"
     		print*, "DP must be dimensioned as (LMAX+1) where LMAX is ", lmax
     		print*, "Input array is dimensioned ", size(dp)
     		stop
     	elseif (lmax < 0) then
     		print*, "Error --- PlBar_d1"
     		print*, "LMAX must be greater than or equal to 0."
     		print*, "Input value is ", lmax
     		stop
     	elseif(abs(z) > 1.0d0) then
     		print*, "Error --- PlBar_d1"
     		print*, "ABS(Z) must be less than or equal to 1."
     		print*, "Input value is ", z
     		stop
     	endif

      	if (z == 1.0d0) then

      		do l=0, lmax
      			p(1:lmax+1) = sqrt( dble(2*l+1))
      			dp(l+1) = sqrt( dble(2*l+1)) * dble(l)*dble(l+1)/2.0d0
      		enddo

      	elseif (z == -1.0d0) then

      		do l=0, lmax
      			p(l+1) = sqrt( dble(2*l+1) ) * dble((-1)**l)
      			dp(l+1) =  sqrt( dble(2*l+1)) *  dble(l)*dble(l+1) * dble((-1)**(l-1)) / 2.0d0
      		enddo

      	else

		sinsq = (1.0d0 - z**2)

   		pm2  = 1.d0/sqrt(4.0d0*pi)
      		p(1) = pm2
      		dp(1) = 0.0d0

      		pm1  = sqrt(3.0d0) * z / sqrt(4.0d0*pi)
      		p(2) = pm1
      		dp(2) = sqrt(3.0d0) / sqrt(4.0d0*pi)

      		do l = 2, lmax
         		pl = ( sqrt(dble(2*l-1))  * z * pm1 - &
         			dble(l-1) * pm2 / sqrt(dble(2*l-3)) ) * &
         			sqrt(dble(2*l+1))/dble(l)
         		p(l+1) = pl
         		dp(l+1) = dble(l) *( sqrt( dble(2*l+1)/dble(2*l-1) ) * &
      				p(l) - z * pl ) / sinsq
         		pm2  = pm1
         		pm1  = pl
      		enddo

      	endif

end subroutine PlON_d1


module convert_mod
   implicit none
contains
   subroutine cels_from_fahr(degrees_fahr,degrees_cels)
   real, intent(in)  :: degrees_fahr
   real, intent(out) :: degrees_cels
   degrees_cels = (degrees_fahr-32)/1.8
   end subroutine cels_from_fahr
end module convert_mod

program xtemperature
   use convert_mod, only: cels_from_fahr
   real    :: deg_f,deg_c
   integer :: i
   write (*,"(2a10)") "degrees_F","degrees_C"
   do i=12,100,20
      deg_f = real(i)
      call cels_from_fahr(deg_f,deg_c)
      write (*,"(2f10.1)") deg_f,deg_c
   end do
end program xtemperature


program array_op_5
implicit none

real :: a(2, 2, 2), b(2, 2, 2), c(2, 2, 2)
real :: d(2, 2, 2)
integer :: i, j, k

do i = 1, 2
    do j = 1, 2
        do k = 1, 2
            a(i, j, k) = i*i + j*j + k*k
            b(i, j, k) = 2*(i*j + j*k + i*k)
            c(i, j, k) = 0
        end do
    end do
end do

d = asquare(a, b, c)
call check(d)

contains

    function asquare(a, b, c) result(d)
        implicit none

        real :: a(:, :, :), b(:, :, :), c(:, :, :)
        real :: d(2, 2, 2)

        d = a + b + c

    end function asquare

    subroutine check(c)
    implicit none

    real, intent(in) :: c(:, :, :)

    integer :: i, j, k

    do i = lbound(c, 1), ubound(c, 1)
        do j = lbound(c, 2), ubound(c, 2)
            do k = lbound(c, 3), ubound(c, 3)
                if(c(i, j, k) /= (i + j + k)**2) error stop
            end do
        end do
    end do

    end subroutine check

end program


!------------------------------------------------------------------------------+
! MATRIX PROCEDURES
! D. Everhart
!------------------------------------------------------------------------------+
! The MIT License (MIT)
!
! Copyright (c) 2016 Daniel Everhart
!
! Permission is hereby granted, free of charge, to any person obtaining
! a copy of this software and associated documentation files (the
! "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish,
! distribute, sublicense, and/or sell copies of the Software, and to
! permit persons to whom the Software is furnished to do so, subject
! to the following conditions:
!
! The above copyright notice and this permission notice shall be
! included in all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
! SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!
!------------------------------------------------------------------------------+
! These subroutines have evolved significantly over the years.
! They began as a undergraduate classroom assignment, and evolved to
! what they are now.
!
! When writing code for numerical analysis, I inevitability have
! the need to do some matrix operations and most of the time, this
! includes matrix inversion.
!
! The PROGRAM and two (2) following SUBROUTINEs demonstrate how to use
! this module.  They may be commented out in order to compile this as a
! library.
!------------------------------------------------------------------------------+
! AE 227 FALL 1994 - Wichita State University
!   MGAUSJ - Gauss-Jordan elimination
! AE 527 FALL 1996 - Wichita State University
!   MGAUSB - Gauss elimination with back substitution (more efficient)
! 2004 - PRESENT - Abstraction of procedures and cleanup.
! MAR 2016 - Cleanup and preparation of messages for use by others.
! JUL 2016 - Adapted to F90 module.
!------------------------------------------------------------------------------+
MODULE LINALG

  INTERFACE MRND
    MODULE PROCEDURE MRND_SEED,MRND_NO_SEED
  END INTERFACE MRND
                               CONTAINS

  SUBROUTINE MINIT(M,VAL)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    REAL(KIND=8),INTENT(IN)    :: VAL
    INTEGER SH(2),I,J
    SH = SHAPE(M)
    FORALL (I=1:SH(1),J=1:SH(2)) M(I,J) = VAL
  END SUBROUTINE MINIT

  SUBROUTINE MRND_SEED(M,SEED)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER(KIND=4),INTENT(IN) :: SEED
    INTEGER SH(2),I,J
    SH = SHAPE(M)
    CALL SRAND(SEED)
    !  Note, RAND cannot be called from FORALL construct.
    DO I=1,SH(1)
    DO J=1,SH(2)
      M(I,J) = DBLE(RAND())
    END DO
    END DO
  END SUBROUTINE MRND_SEED

  SUBROUTINE MRND_NO_SEED(M)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    CALL MRND_SEED(M,0)
  END SUBROUTINE MRND_NO_SEED

  SUBROUTINE MIDEN(M)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER SH(2),I,J
    SH = SHAPE(M)
    FORALL (I=1:SH(1),J=1:SH(2),I.NE.J) M(I,J) = 0D0
    FORALL (I=1:SH(1),J=1:SH(2),I.EQ.J) M(I,J) = 1D0
  END SUBROUTINE MIDEN

  SUBROUTINE MPRT(M)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER SH(2),I,J
    CHARACTER(LEN=9)           :: F
    SH = SHAPE(M)
    WRITE(F,'(A1I2A6)') '(', SH(2), 'F10.4)'
    DO I = 1, SH(1)
    WRITE(6,F) (M(I,J), J=1, SH(2))
    END DO
  END SUBROUTINE MPRT

  SUBROUTINE MMUL(A,B,P)
!
!              [A]     *         [B]         =         [P]
!
!          | A11 A12 |   | B11 B12 B13 B14 |   | P11 P12 P13 P14 |
!          | A21 A22 | * | B21 B22 B23 B12 | = | P21 P22 P23 P24 |
!          | A31 A32 |                         | P31 P32 P33 P34 |
!
    IMPLICIT NONE
    REAL(KIND=8),INTENT(IN ) :: A(:,:), B(:,:)
    REAL(KIND=8),INTENT(OUT) :: P(:,:)
    INTEGER(KIND=4)          :: I,J,K,AS(2),BS(2),PS(2)
    REAL(KIND=8)             :: SUM
!
    AS = SHAPE(A)
    BS = SHAPE(B)
    PS = SHAPE(P)
!
    IF (AS(2).NE.BS(1)) THEN
      WRITE(0,910) AS(2), BS(1)
      STOP
    END IF
    IF (PS(1).LT.AS(1)) THEN
      WRITE(0,920) PS(1), AS(1)
      STOP
    END IF
    IF (PS(2).LT.BS(2)) THEN
      WRITE(0,930) PS(2), BS(2)
      STOP
    END IF
!
!             <-------- K -------->
!
!      P11 = A11 * B11 + A12 * B21   ^   ^
!      P21 = A21 * B11 + A22 * B21   I   |
!      P31 = A31 * B11 + A32 * B21   v   |
!                                        |
!      P12 = A11 * B12 + A12 * B22   ^   |
!      P22 = A21 * B12 + A22 * B22   I   |
!      P32 = A31 * B12 + A32 * B22   v
!                                        J
!      P13 = A11 * B13 + A12 * B23   ^
!      P23 = A21 * B13 + A22 * B23   I   |
!      P33 = A31 * B13 + A32 * B23   v   |
!                                        |
!      P14 = A11 * B14 + A12 * B24   ^   |
!      P24 = A21 * B14 + A22 * B24   I   |
!      P34 = A31 * B14 + A32 * B24   v   v
!
    DO I = 1, PS(1)
      DO J = 1, PS(2)
        SUM = 0D0
        DO K = 1, AS(2)
          SUM = SUM + A(I,K) * B(K,J)
        END DO
        P(I,J) = SUM
      END DO
    END DO
!
    910 FORMAT('*** FATAL ERRROR: MMUL: MATRIX A COLUMNS MUST MATCH' &
             ' MATRIX B ROWS:',/,18X,I8, '   .NE.   ', I8)
    920 FORMAT('*** FATAL ERRROR: MMUL: MATRIX P ROWS MUST AT LEAST' &
             ' EQUAL MATRIX A ROWS:',/,18X,I8, '   .LT.   ', I8)
    930 FORMAT('*** FATAL ERRROR: MMUL: MATRIX P COLUMNS MUST AT LEAST' &
             ' EQUAL MATRIX B COLUMNS:',/,18X,I8, '   .LT.   ', I8)
  END SUBROUTINE MMUL

  SUBROUTINE MGAUSJ(M)
!   Consider the matrix below representing the system of equations:
!
!                            [A]*[x] = B
!
!                  | A11 A12 A13 A14 A15 B16 B17 |
!                  | A21 A22 A23 A24 A25 B26 B27 |
!                  | A31 A32 A33 A34 A35 B36 B37 |
!                  | A41 A42 A43 A44 A45 B46 B47 |
!                  | A51 A52 A53 A54 A55 B56 B57 |
!
!   This procedure performs Gauss-Jordan elimination with repeated calls
!   to MGJECOL to zero out non-diagonal elements, and normalize to 1.0
!   resulting in the following:
!
!                  | 1.0 0.0 0.0 0.0 0.0 X16 X17 |
!                  | 0.0 1.0 0.0 0.0 0.0 X26 X27 |
!                  | 0.0 0.0 1.0 0.0 0.0 X36 X37 |
!                  | 0.0 0.0 0.0 1.0 0.0 X46 X47 |
!                  | 0.0 0.0 0.0 0.0 1.0 X56 X57 |
!
!   X values are where the solution matrix is stored.
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    REAL(KIND=8)               :: TMP
    INTEGER(KIND=4)            :: I,J,SH(2)
!
    SH = SHAPE(M)
    IF (SH(1).GT.SH(2)) THEN
      WRITE(0,910), SH(1), SH(2)
      STOP
    END IF
!
    DO I = 1, SH(1)
      CALL MPPVT(M,I)
      CALL MGJECOL(M,I)
      TMP = M(I,I)
      DO J = I, SH(2)
        M(I,J) = M(I,J) / TMP
      END DO
    END DO
!
    899 RETURN
    910 FORMAT('*** FATAL ERRROR: MGAUSJ: MATRIX ROWS LARGER THAN'       &
               ' COLUMNS',/,18X,I8, '   .GT.   ',I8)
  END SUBROUTINE MGAUSJ

!------------------------------------------------------------------------------+
! MGAUSB: Matrix GAUSs elimination with Back substitution
!------------------------------------------------------------------------------+
!    M : Matrix
! ROWS : Number of rows
! COLS : Number of columns
!------------------------------------------------------------------------------+
! Consider the matrix below representing the system of equations:
!
!                          [A]*[x] = B
!
!                | A11 A12 A13 A14 A15 B16 B17 |
!                | A21 A22 A23 A24 A25 B26 B27 |
!                | A31 A32 A33 A34 A35 B36 B37 |
!                | A41 A42 A43 A44 A45 B46 B47 |
!                | A51 A52 A53 A54 A55 B56 B57 |
!
! This procedure performs Gauss elimination with repeated calls
! to MGECOL leave an upper triangle matrix.  Junk values are left in
! place below the diagonal to save operations.  This results in the
! following:
!
!                | A11 A12 A13 A14 A15 B16 B17 |
!                | JNK A22 A23 A24 A25 B26 B27 |
!                | JNK JNK A33 A34 A35 B36 B37 |
!                | JNK JNK JNK A44 A45 B46 B47 |
!                | JNK JNK JNK JNK A55 B56 B57 |
!
! The final step is to perform back substitution callin MBSUB resulting
! in the following:
!
!                | A11 A12 A13 A14 A15 X16 X17 |
!                | JNK A22 A23 A24 A25 X26 X27 |
!                | JNK JNK A33 A34 A35 X36 X37 |
!                | JNK JNK JNK A44 A45 X46 X47 |
!                | JNK JNK JNK JNK A55 X56 X57 |
!
! X values are where the solution matrix is stored.
!
!------------------------------------------------------------------------------+
  SUBROUTINE MGAUSB(M)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER(KIND=4)            :: SH(2)
    INTEGER I
!
    SH = SHAPE(M)
    IF (SH(1).GT.SH(2)) THEN
      WRITE(0,910), SH(1), SH(2)
      STOP
    END IF
!
    CALL MGAUS(M)
    CALL MBSUB(M)
!
  910 FORMAT('*** FATAL ERRROR: MGAUSB: MATRIX ROWS LARGER THAN'   &
             ' COLUMNS',/,18X,I8, '   .GT.   ',I8)
  999 RETURN
  END SUBROUTINE
!------------------------------------------------------------------------------+
! MGAUS: Matrix GAUSs elimination
!------------------------------------------------------------------------------+
!    M : Matrix
! ROWS : Number of rows
! COLS : Number of columns
!------------------------------------------------------------------------------+
! Consider the matrix below representing the system of equations:
!
!                          [A]*[x] = B
!
!                | A11 A12 A13 A14 A15 B16 B17 |
!                | A21 A22 A23 A24 A25 B26 B27 |
!                | A31 A32 A33 A34 A35 B36 B37 |
!                | A41 A42 A43 A44 A45 B46 B47 |
!                | A51 A52 A53 A54 A55 B56 B57 |
!
! This procedure performs Gauss elimination with repeated calls
! to MGECOL leave an upper triangle matrix.  Junk values are left in
! place below the diagonal to save operations.  This results in the
! following:
!
!                | A11 A12 A13 A14 A15 B16 B17 |
!                | JNK A22 A23 A24 A25 B26 B27 |
!                | JNK JNK A33 A34 A35 B36 B37 |
!                | JNK JNK JNK A44 A45 B46 B47 |
!                | JNK JNK JNK JNK A55 B56 B57 |
!
!------------------------------------------------------------------------------+
  SUBROUTINE MGAUS(M)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER(KIND=4)            :: I,SH(2)
!
    SH = SHAPE(M)
    IF (SH(1).GT.SH(2)) THEN
      WRITE(0,910), SH(1), SH(2)
      STOP
    END IF
!
    DO I = 1, SH(1)
    CALL MPPVT(M,I)
    CALL MGECOL(M,I)
    ENDDO
!
    910 FORMAT('*** FATAL ERRROR: MGAUS: MATRIX ROWS LARGER THAN'  &
             ' COLUMNS',/,18X,I8, '   .GT.   ',I8)
  END SUBROUTINE
!------------------------------------------------------------------------------+
! MPPVT: Matrix Partial PiVoT
!------------------------------------------------------------------------------+
  SUBROUTINE MPPVT(M,ROW)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER(KIND=4),INTENT(IN) :: ROW
    INTEGER(KIND=4)            :: SH(2),J,K
    REAL(KIND=8)               :: TOL,TMP
    PARAMETER (TOL=1.0D-12)
!
    SH = SHAPE(M)
    IF (ABS(M(ROW,ROW)).LE.TOL) THEN
    DO J = ROW+1, SH(1)
      IF (ABS(M(J,ROW)).GE.TOL) EXIT
    ENDDO
    DO K = ROW,SH(2)
      TMP = M(ROW,K)
      M(ROW,K) = M(J,K)
      M(J,K) = TMP
    ENDDO
    END IF
  END SUBROUTINE MPPVT
!------------------------------------------------------------------------------+
! MGJECOL: Matrix Gauss-Jordan Eliminate COLumn
!------------------------------------------------------------------------------+
! Performs Gauss elimination on a particular column.  This procedure is
! called multiple times to columns for Gauss-Jordan elimination.
! Consider the following matrix:
!
!                | A11 A12 A13 A14 A15 A16 A17 |
!                | 0.0 A22 A23 A24 A25 A26 A27 |
!                | 0.0 A32 A33 A34 A35 A36 A37 |
!                | 0.0 A42 A43 A44 A45 A46 A47 |
!                | 0.0 A52 A53 A54 A55 A56 A57 |
!
!
!   Column 2 is the next to be zeroed.  This is done by repeated calls
!   to MGJEROW.  The result is the following:
!
!                | A11 0.0 A13 A14 A15 A16 A17 |
!                | 0.0 A22 A23 A24 A25 A26 A27 |
!                | 0.0 0.0 A33 A34 A35 A36 A37 |
!                | 0.0 0.0 A43 A44 A45 A46 A47 |
!                | 0.0 0.0 A53 A54 A55 A56 A57 |
!
!   Note:  This procedure calls MGJEROW for every row in the matrix.
!   Repeated calls, result in a matrix with non-zero values only on
!   the diagonal.  This is less efficient that elimination resulting
!   in a upper diagonal matrix to be used for backward substitution.
!
!------------------------------------------------------------------------------+
!    M : Matrix
!  COL : Associated column to be zeroed for elimination.
!------------------------------------------------------------------------------+
  SUBROUTINE MGJECOL(M,COL)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER(KIND=4),INTENT(IN) :: COL
    INTEGER(KIND=4)            :: SH(2),J
!
    SH = SHAPE(M)
    DO J = 1, SH(1)
      IF (J.NE.COL) CALL MGEROW(M,J,COL,1)
    ENDDO
  END SUBROUTINE MGJECOL
!------------------------------------------------------------------------------+
! MGECOL: Matrix Gauss Eliminate COLumn
!------------------------------------------------------------------------------+
! Performs Gauss elimination on a particular column.  This procedure is
! called multiple times to columns for Gauss-Jordan elimination.
! Consider the following matrix:
!
!                | A11 A12 A13 A14 A15 A16 A17 |
!                | JNK A22 A23 A24 A25 A26 A27 |
!                | JNK A32 A33 A34 A35 A36 A37 |
!                | JNK A42 A43 A44 A45 A46 A47 |
!                | JNK A52 A53 A54 A55 A56 A57 |
!
!
!   Column 2 is the next to be 'zeroed'.  This is done by repeated calls
!   to MGEROW with SCOL=COL+1.  The result is the following:
!
!                | A11 A12 A13 A14 A15 A16 A17 |
!                | JNK A22 A23 A24 A25 A26 A27 |
!                | JNK JNK A33 A34 A35 A36 A37 |
!                | JNK JNK A43 A44 A45 A46 A47 |
!                | JNK JNK A53 A54 A55 A56 A57 |
!
!   Note:  This procedure calls MGEROW for rows below the diagonal at
!   the particular column in the matrix.
!
!   Repeated calls, result in a matrix with junk (JNK) values below
!   the diagonal and actuals values on and above the diagonal.  The
!   junk values are left in place to save operations for large systems.
!
!------------------------------------------------------------------------------+
!    M : Matrix
!  COL : Associated column to be zeroed for elimination.
!------------------------------------------------------------------------------+
  SUBROUTINE MGECOL(M,COL)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER(KIND=4),INTENT(IN) :: COL
    INTEGER(KIND=4)            :: SH(2),J
!
    SH = SHAPE(M)
    DO J = COL+1, SH(1)
      CALL MGEROW(M,J,COL,COL+1)
    ENDDO
  END SUBROUTINE MGECOL
!------------------------------------------------------------------------------+
! MGJEROW: Matrix Gauss-Jordan Eliminate ROW
!------------------------------------------------------------------------------+
! Performs Gauss elimination on a particular row.  This procedure is
! called multiple times to eliminate a particular column. Consider
! the following matrix:
!
!                | A11 A12 A13 A14 A15 A16 A17 |
!                | 0.0 A22 A23 A24 A25 A26 A27 |
!                | 0.0 A32 A33 A34 A35 A36 A37 |
!                | 0.0 A42 A43 A44 A45 A46 A47 |
!                | 0.0 A52 A53 A54 A55 A56 A57 |
!
!   Row 3, column 2 is the next to be zeroed.  This is done by
!   subtracting a scaled row 2 from row 3.  Scale factor RATIO is
!   calculated by:
!
!                        RATIO = A32 / A22
!
!   This ratio is chosen so that the result at row 3, column 2 will
!   calculate to zero.
!
!                  A32 = A32 - A22 * A32 / A22  (Results in 0.0)
!                  A33 = A33 - A23 * A32 / A22
!                  A34 = A34 - A24 * A32 / A22
!                  A35 = A35 - A25 * A32 / A22
!                  A36 = A36 - A26 * A32 / A22
!                  A37 = A37 - A27 * A32 / A22
!
!   The resulting state of the matrix after this procedure is:
!
!                | A11 A12 A13 A14 A15 A16 A17 |
!                | 0.0 A22 A23 A24 A25 A26 A27 |
!                | 0.0 0.0 A33 A34 A35 A36 A37 |
!                | 0.0 A42 A43 A44 A45 A46 A47 |
!                | 0.0 A52 A53 A54 A55 A56 A57 |
!
!   Note:  This procedure does not require that ROW .GT. COL.  The
!   result is that in the above example, the same operation could be
!   performed on row 1 to zero out A12.  This is useful if the
!   elimination is Gauss-Jordan where all elements not on the diagonal
!   are zeroed out.
!
!   Additionally, this procedure is called with a starting column. To
!   save operations, the start column may be set to COL+1 when calling
!   and nothing will be done to the elements to the left of COL.  This
!   is useful when reducing the matrix to a upper triangle matrix.
!
!------------------------------------------------------------------------------+
!    M : Matrix
!  ROW : Matrix row on which to perform elimination
!  COL : Associated column to be zeroed for elimination.
! SCOL : Column to begin elimination
!------------------------------------------------------------------------------+
  SUBROUTINE MGEROW(M,ROW,COL,SCOL)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER(KIND=4),INTENT(IN) :: ROW,COL,SCOL
    DOUBLE PRECISION TOL,RATIO
    PARAMETER (TOL=1.0D-12)
    INTEGER I,J,SH(2)
!
      SH = SHAPE(M)
      IF (ABS(M(ROW,COL)).GE.TOL) THEN
        RATIO = M(ROW,COL) / M(COL,COL)
        DO I = SCOL, SH(2)
        IF (I.EQ.COL) THEN
          M(ROW,I) = 0D0 ! Zero by definition.
                         ! don't calculate, just zero.
        ELSE
          M(ROW,I) = M(ROW,I) - RATIO * M(COL,I)
        ENDIF
       ENDDO
      ELSE
        M(ROW,COL) = 0D0
      END IF
  END SUBROUTINE MGEROW
!------------------------------------------------------------------------------+
! MBSUB: Matrix Back SUBstitution
!------------------------------------------------------------------------------+
! Consider the reduced system.
!
!                | A11 A12 A13 A14 A15 B16 B17 |
!                | JNK A22 A23 A24 A25 B26 B27 |
!                | JNK JNK A33 A34 A35 B36 B37 |
!                | JNK JNK JNK A44 A45 B46 B47 |
!                | JNK JNK JNK JNK A55 B56 B57 |
!
! JNK values are assumed to be 0.0.  Recall that this is a set
! of equations for each B column vector:
!
!      A11*X16 + A12*X26 + A13*X36 + A14*X46 + A15*X56 = B16
!                A22*X26 + A23*X36 + A24*X46 + A25*X56 = B26
!                          A33*X36 + A34*X46 + A35*X56 = B36
!                                    A44*X46 + A45*X56 = B46
!                                              A55*X56 = B56
!
!      A11*X17 + A12*X27 + A13*X37 + A14*X47 + A15*X57 = B17
!                A22*X27 + A23*X37 + A24*X47 + A25*X57 = B27
!                          A33*X37 + A34*X47 + A35*X57 = B37
!                                    A44*X47 + A45*X57 = B47
!                                              A55*X57 = B57
!
! These equations may be solved starting from the bottom:
!
!                          <------------- K --------------->
!
!  |  |     X56 = (B56                                        ) / A55
!  |  |     X46 = (B46 - A45*X56                              ) / A44
!  |  J     X36 = (B36 - A34*X46 - A35*X56                    ) / A33
!  |  |     X26 = (B26 - A23*X36 - A24*X46 - A25*X56          ) / A22
!  |  v     X16 = (B16 - A12*X26 - A13*X36 - A14*X46 - A15*X56) / A11
!  I
!  |  |     X57 = (B57                                        ) / A55
!  |  |     X47 = (B47 - A45*X57                              ) / A44
!  |  J     X37 = (B37 - A34*X47 - A35*X57                    ) / A33
!  |  |     X27 = (B27 - A23*X37 - A24*X47 - A25*X57          ) / A22
!  v  v     X17 = (B17 - A12*X27 - A13*X37 - A14*X47 - A15*X57) / A11
!
! The resulting aray has the solution vectors in place of the B
! vectors.
!
!                | A11 A12 A13 A14 A15 X16 X17 |
!                | JNK A22 A23 A24 A25 X26 X27 |
!                | JNK JNK A33 A34 A35 X36 X37 |
!                | JNK JNK JNK A44 A45 X46 X47 |
!                | JNK JNK JNK JNK A55 X56 X57 |
!
!------------------------------------------------------------------------------+
!    M : Matrix
!------------------------------------------------------------------------------+
  SUBROUTINE MBSUB(M)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(INOUT) :: M(:,:)
    INTEGER I,J,K,SH(2)
    DOUBLE PRECISION SUM
    SH = SHAPE(M)
    DO I = SH(1)+1, SH(2)
      DO J = SH(1), 1, -1
        SUM = 0D0
        DO K = SH(1), J+1, -1
          SUM = SUM + M(J,K) * M(K,I)
        ENDDO
        M(J,I) = (M(J,I) - SUM) / M(J,J)
      ENDDO
    ENDDO
  END SUBROUTINE MBSUB
END MODULE LINALG
!------------------------------------------------------------------------------+
PROGRAM MTEST
  IMPLICIT NONE
  CALL SMTEST
  WRITE(*,*)
  CALL BNMK
END PROGRAM MTEST
!------------------------------------------------------------------------------+
SUBROUTINE BNMK
  USE LINALG
  IMPLICIT NONE
  INTEGER ROWS,COLS,SZ,STIME,ETIME,TM(9)
  PARAMETER (ROWS=100, COLS=2*ROWS, SZ=ROWS*COLS)
  DOUBLE PRECISION D(ROWS,COLS)
  DOUBLE PRECISION D1(ROWS,ROWS), D2(ROWS,ROWS)
  EQUIVALENCE (D1(1,1), D(1,1)), (D2(1,1), D(1,ROWS+1))
  DATA D /SZ*0D0/
!
  STIME = TIME()
  WRITE(*,810) 'START MGAUSJ'
  CALL MRND(D1)
  CALL MIDEN(D2)
  CALL MGAUSJ(D)
  ETIME = TIME()
  CALL GMTIME(ETIME-STIME, TM)
  WRITE(*,820) 'END MGAUSJ  ', TM(3),':',TM(2),':',TM(1)
!
  WRITE(*,*)
!
  STIME = TIME()
  WRITE(*,810) 'START MGAUSB'
  CALL MRND(D1)
  CALL MIDEN(D2)
  CALL MGAUSB(D)
  ETIME = TIME()
  CALL GMTIME(ETIME-STIME, TM)
  WRITE(*,820) 'END MGAUSB  ', TM(3),':',TM(2),':',TM(1)
!
  810 FORMAT('0*** ',A12)
  820 FORMAT('0*** ',A12,I2.2,A,I2.2,A,I2.2)
  999 RETURN
END SUBROUTINE BNMK
!------------------------------------------------------------------------------+
SUBROUTINE SMTEST
  USE LINALG
  IMPLICIT NONE
  INTEGER COLS, ROWS, SZ
  INTEGER I, J
  PARAMETER (COLS=6, ROWS=3, SZ=COLS*ROWS)
  DOUBLE PRECISION D(ROWS,COLS), E(ROWS,ROWS)
  DOUBLE PRECISION D1(ROWS,ROWS), D2(ROWS,ROWS)
  EQUIVALENCE (D1(1,1), D(1,1)), (D2(1,1), D(1,4))
  DATA D /SZ*0D0/
!
  WRITE(6,910)
  WRITE(6,920)
  WRITE(6,910)
  WRITE(6,980)'MATRIX D IS COMPRISED OF D1 AND D2.'
  WRITE(6,980)'       [ D ] =  [ D1 | D2 ]'
  WRITE(6,980)'MATRIX E IS SQUARE DIMENSIONED THE SAME AS'
  WRITE(6,980)'            D1 AND D2'
  WRITE(6,910)
!
  WRITE(6,*)
  WRITE(6,990)'TESTING MINIT ON [D].'
  CALL MINIT(D, 1D0)
  CALL MPRT(D)
!
  WRITE(6,*)
  WRITE(6,990)'TESTING MRND ON [D1].'
  CALL MRND(D1,0)
  CALL MPRT(D)
!
  WRITE(6,*)
  WRITE(6,990)'TESTING MIDEN ON [D2].'
  CALL MIDEN(D2)
  CALL MPRT(D)
!
  WRITE(6,*)
  WRITE(6,990)'ZEROING ELEMENTS D(2,1), D(2,2), D(2,3)...'
  D(2,1) = 0D0
  D(2,2) = 0D0
  D(2,3) = 0D0
  CALL MPRT(D)
!
  WRITE(6,*)
  WRITE(6,990)'RUNNING GAUSS-JORDAN ELIMINATION ON [D]'
  CALL MGAUSJ(D)
  CALL MPRT(D)
!
  WRITE(6,*)
  WRITE(6,990)'RANDOMIZE [D1].'
  CALL MRND(D1,0)
  CALL MPRT(D)
!
  WRITE(6,*)
  WRITE(6,990)'IDENTITY [D2].'
  CALL MIDEN(D2)
  CALL MPRT(D)
!
!     Copy D1 into E
!
  DO I=1,ROWS
    DO J=1,ROWS
      E(I,J) = D1(I,J)
    END DO
  END DO
!
  WRITE(6,*)
  WRITE(6,990)'RUNNING GAUSS ELIMINATION AND BACK SUBSTITUTION ON'  &
               // ' [D]'
  CALL MGAUSB(D)
  CALL MPRT(D)
!
  WRITE(6,*)
  WRITE(6,990)'MULTIPLYING MATRIX BY INVERSE [D1] = [D2] * [E]'
  CALL MMUL(D2,E,D1)
  CALL MPRT(D1)
!
  910 FORMAT('********************************************************' &
             '************************')
  920 FORMAT('******************************* RUNNING UNIT TESTS '      &
             '*****************************')
  980 FORMAT(15X,A)
  990 FORMAT('0*** ',A)
  999 RETURN
END SUBROUTINE SMTEST


      PROGRAM xhypgeo
C     driver for routine hypgeo
      COMPLEX a,b,c,z,zi,hypgeo,q1,q2,q3,q4
      REAL x,y
      a=0.5
      b=1.
      c=1.5
1     write(*,*) 'INPUT X,Y OF COMPLEX ARGUMENT:'
      read(*,*,END=999) x,y
      z=cmplx(x,y)
      q1=hypgeo(a,b,c,z*z)
      q2=0.5*log((1.+z)/(1.-z))/z
      q3=hypgeo(a,b,c,-z*z)
      zi=cmplx(-y,x)
      q4=0.5*log((1.+zi)/(1.-zi))/zi
      write(*,*) '2F1(0.5,1.0,1.5;Z**2) =',q1
      write(*,*) 'check using log form   ',q2
      write(*,*) '2F1(0.5,1.0,1.5;-Z**2)=',q3
      write(*,*) 'check using log form   ',q4
      goto 1
999   END

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


program short_test
    implicit none
    integer :: i, N, k
    real :: x, h, y

    h = 0.1
    N = 10. / h

    ! method for the ODE x'(t) = f(x,t) = sin(x) + sin(t)
    x = 1
    write(*,*)0., x
    do i=1,N
        ! Use 5 iterations of Newton's method to find x_i
        ! for method
        ! x_i = x_{i-1} + h/2 * f(x_i, t_i) + h/2 * f(x_{i-1}, t_{i-1})
        y = x ! y = x_{i-1}
        do k = 1,5
            x = x - (x - 0.5 * h * f(x, i * h) - y - 0.5 * h * f(y, (i - 1) * h)) / (1. - 0.5 * h * df(x, i * h))
        end do
        write(*,*)i * h, x
    end do

contains
    function f(x,t)
        implicit none
        real, intent(in) :: x, t
        real :: f
        f = sin(x) + sin(t)
    end function

    ! the partial derivative of f with respect to x
    function df(x,t)
        implicit none
        real, intent(in) :: x, t
        real :: df
        df = cos(x)
    end function
end program


program determinant
  use gauss
  use mats
  implicit none

  real, allocatable :: mat(:, :)
  integer :: n
  integer :: det_sign

  print *, 'Enter matrix side length:'
  read (*, *) n
  allocate(mat(n, n))

  print *, 'Enter matrix values:'
  read (*, *) mat

  call echelon(mat, det_sign)
  print *, 'Determinant:', det_sign * tri_det(mat)
end program determinant


C$Procedure      MTXM  ( Matrix transpose times matrix, 3x3 )

      SUBROUTINE MTXM ( M1, M2, MOUT )

C$ Abstract
C
C     Multiply the transpose of a 3x3 matrix and a 3x3 matrix.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C
C$ Declarations

      DOUBLE PRECISION   M1   ( 3,3 )
      DOUBLE PRECISION   M2   ( 3,3 )
      DOUBLE PRECISION   MOUT ( 3,3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     M1         I   3x3 double precision matrix.
C     M2         I   3x3 double precision matrix.
C     MOUT       O   3x3 double precision matrix which is the product
C                    (M1**T) * M2.
C
C$ Detailed_Input
C
C     M1         is any 3x3 double precision matrix. Typically,
C                M1 will be a rotation matrix since then its
C                transpose is its inverse (but this is NOT a
C                requirement).
C
C     M2         is any 3x3 double precision matrix.
C
C$ Detailed_Output
C
C     MOUT       is s 3x3 double precision matrix. MOUT is the
C                product MOUT = (M1**T) x M2.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The code reflects precisely the following mathematical expression
C
C        For each value of the subscripts I and J from 1 to 3:
C
C        MOUT(I,J) = Summation from K=1 to 3 of  ( M1(K,I) * M2(K,J) )
C
C     Note that the reversal of the K and I subscripts in the left-hand
C     matrix M1 is what makes MOUT the product of the TRANSPOSE of M1
C     and not simply of M1 itself.
C
C$ Examples
C
C     Let M1  = | 1.0D0  2.0D0  3.0D0 |
C               |                     |
C               | 4.0D0  5.0D0  6.0D0 |
C               |                     |
C               | 7.0D0  8.0D0  9.0D0 |
C
C
C         M2  = |  1.0D0   1.0D0  0.0D0 |
C               |                       |
C               | -1.0D0   1.0D0  0.0D0 |
C               |                       |
C               |  0.0D0   0.0D0  1.0D0 |
C
C     then the call
C
C        CALL MTXM ( M1, M2, MOUT )
C
C     produces the matrix
C
C
C        MOUT = | -3.0D0   5.0D0  7.0D0 |
C               |                       |
C               | -3.0D0   7.0D0  8.0D0 |
C               |                       |
C               | -3.0D0   9.0D0  9.0D0 |
C
C
C$ Restrictions
C
C     The user is responsible for checking the magnitudes of the
C     elements of M1 and M2 so that a floating point overflow does
C     not occur.  (In the typical use where M1 and M2 are rotation
C     matrices, this not a risk at all.)
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     matrix_transpose times matrix 3x3_case
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      PRODM(3,3)

      INTEGER               I
      INTEGER               J

C
C  Perform the matrix multiplication
C
      DO   I=1,3
         DO   J=1,3
            PRODM(I,J) = M1(1,I)*M2(1,J)
     .                 + M1(2,I)*M2(2,J)
     .                 + M1(3,I)*M2(3,J)
         END DO
      END DO

C
C  Move the result into MOUT
C
      CALL MOVED ( PRODM, 9, MOUT )

      RETURN
      END


program ch0804
    ! Rank 2 Array Sections
    implicit none

    integer, parameter :: nrow = 5
    integer, parameter :: ncol = 6
    real, dimension(1:nrow,1:ncol) :: exam_results = 0.
    real, dimension(1:nrow) :: people_average = 0.
    real, dimension(1:ncol) :: subject_average = 0.
    integer :: r, c

    do r = 1, nrow
        read *, exam_results(r,1:ncol)
    end do
    exam_results(1:nrow,3) = exam_results(1:nrow,3)*2.5

    do r = 1, nrow
        do c = 1, ncol
            people_average(r) = people_average(r)+&
            exam_results(r,c)
        end do
    end do
    people_average = people_average/ncol

    do c = 1, ncol
        do r = 1, nrow
            subject_average(c) = subject_average(c)+&
            exam_results(r,c)
        end do
    end do
    subject_average = subject_average/nrow

    print *, ' People averages'
    print *, people_average
    print *, ' Subject averages'
    print *, subject_average
end program


module spline
!! Spline utilities
implicit none

private :: findIdx

contains

subroutine cubspline_init(n, x, y,y2)
  !! Initialize a cubic spline
  integer, intent(in) :: n !! data length
  real(8), intent(in) :: x(n) !! x input data
  real(8), intent(in) :: y(n) !! y(x)
  real(8), intent(out) :: y2(n) !! spline data

  integer :: i,k
  real(8) :: p,qn,sig, un,u(n), yp1,yp2,h

  h = x(2)-x(1)

  y2(1)=0.d0
  u(1)=0.d0
  do i=2,n-1
    sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
    p=sig*y2(i-1)+2.d0
    y2(i)=(sig-1.d0)/p
    yp1=(y(i+1)-y(i))/(x(i+1)-x(i))
    yp2=(y(i)-y(i-1))/(x(i)-x(i-1))
    u(i)=(6.d0*(yp1-yp2)/(x(i+1)-x(i-1))-sig*u(i-1))/p
  end do
  qn=0.d0
  un=0.d0
  y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.d0)
  do k=n-1,1,-1
    y2(k) = y2(k)*y2(k+1) + u(k)
  end do

end subroutine

function cubspline_equalsep_eval_single_nchk(hi, h2sur6,xmin,y,y2, val) result(res)
  !! Evaluate a spline of equally sperated absissa at `val`. Input range is not checked. Helper function.
  real(8) :: res
  real(8), intent(in) :: y(*) !! y(x) data points
  real(8), intent(in) :: y2(*) !! spline data
  real(8), intent(in) :: val  !! value
  real(8), intent(in) :: hi !! 1/h,  where h is step
  real(8), intent(in) :: h2sur6 !! h^2/6, where h is step
  real(8), intent(in) :: xmin !! minimum x value
  integer :: nr2
  real(8) :: a,b

  a=(val-xmin)*hi
  nr2=int(a)
  a = a - real(nr2,8)
  b=1.d0-a
  res=y(nr2+2)*a+y(nr2+1)*b+&
    &(y2(nr2+2)*a*(a*a-1.d0)+y2(nr2+1)*b*(b*b-1.d0))*h2sur6
end function

subroutine cubspline_equalsep_eval(n, x, y, y2, nnew,xnew, ynew)
  !! Evaluates an array of values.
  integer, intent(in) :: n !! data length
  real(8), intent(in) :: x(n) !! input values
  real(8), intent(in) :: y(n) !! y(x) data values
  real(8), intent(in) :: y2(n) !! spline data
  integer, intent(in) :: nnew !! output data length
  real(8), intent(in) :: xnew(nnew) !! values to be evaluated
  real(8), intent(out) :: ynew(nnew) !! result array y(xnew)

  integer :: i,imin, imax
  real(8) :: h2s6,hi,h
  h = x(2) - x(1)
  h2s6 = h*h/6.d0
  hi = 1.d0 / h

  do imin=1,nnew
    if(xnew(imin) > x(1)) exit
    ynew(imin) = y(1)
  end do
  do imax=nnew,1,-1
    if(xnew(imax) < x(n)) exit
    ynew(imax) = y(n)
  end do

  do i=imin,imax
    ynew(i) = cubspline_equalsep_eval_single_nchk(hi, h2s6,x(1),y,y2, xnew(i))
  end do

end subroutine

integer function findIdx(n, x, val)
  !todo: store klo, khi for sequential calls
  integer, intent(in) :: n
  real(8), intent(in) :: x(n)
  real(8), intent(in) :: val
  integer :: klo, khi,k
  klo = 1
  khi = n
  do while(khi-klo>1)
    k=(khi+klo) / 2
    if(x(k) > val) then
      khi = k
    else
      klo=k
    end if
  end do
  findIdx= klo
end function

real(8) function cubspline_eval(n, x, y, y2, val)
  !! Evaluates a value. `val` must be in range.
  integer, intent(in) :: n !! data length
  real(8), intent(in) :: x(n) !! input values
  real(8), intent(in) :: y(n) !! y(x) data values
  real(8), intent(in) :: y2(n) !! spline data
  real(8), intent(in) :: val !! value

  integer :: nr2
  real(8) :: a,dx,b,c,d,h2sur6

  nr2 = findIdx(n,x, val)
  dx = x(nr2+1) - x(nr2)
  a = (val - x(nr2))/dx
  b = 1.0d0 - a
  c = a*(a*a-1.0d0)
  d = b*(b*b - 1.0d0)
  h2sur6 = dx*dx*(1.0d0/6.0d0)
  cubspline_eval = y(nr2 + 1) * a + y(nr2) * b + (y2(nr2 + 1) * c + y2(nr2) * d )* h2sur6

end function

end module


!=====================================
! projectile.f90
! Author: Devansh Shukla
!-------------------------------------

program projectile
    ! Program to compute motion of a particle moving in projectile motion.

    implicit none
    real*8, parameter :: PI=3.141592, g=9.81
    real*8 :: x, y, vx, vy
    real*8 :: theta, v0x, v0y, v0
    real*8 :: t0, tf, dt, t
    character(len=*), parameter :: fmt1 = "(F12.4, F12.4, F12.4, F12.4, F12.4)"

    open(unit=8, file="Projectile.dat")

    print *, "----------------------------------------"
    print *, "Enter v0, theta(deg)"
    read *, v0, theta
    print *, "Enter t0, tf, dt"
    read *, t0, tf, dt
    print *, "----------------------------------------"

    print *, "v0, theta =", v0, theta
    print *, "t0, tf, dt=", t0, tf, dt

    if (v0 .le. 0.0) stop "Illegal value of v0<=0"
    if (theta .lt. 0.0 .or. theta .gt. 90.0 ) &
    stop "Illegal value of theta"
    print *, "----------------------------------------"

    theta = (PI/180.0) * theta      ! theta radians
    v0x = v0*cos(theta)
    v0y = v0*sin(theta)

    print "(A12, A12, A12, A12, A12)", "time", "x(t)", "y(t)", "vx(t)", "vy(t)"
    t = t0
    do while(t <= tf)
        x = v0x * t
        y = v0y * t - 0.5*g*t*t
        vx = v0x
        vy = v0y - g*t
        write (*, fmt1) t, x, y, vx, vy
        write (8, fmt1) t, x, y, vx, vy
        if (y < 0.0) stop "y-ve"
        t = t + dt
    enddo
    print *, "----------------------------------------"
    close(8)
end program projectile


! A program for estimating PI integrating the following formula
! f(a) = 4.d0 / (1.d0 + a*a)

program main
    use mpi
    implicit none
    integer :: num_rects, rank, numprocs, i, ierr
    double precision :: local_sum, estimated_pi, interval, sum_i, x, f, a
    double precision, parameter :: PI25DT = 3.141592653589793238462643d0

    f(a) = 4.d0 / (1.d0 + a*a)

    call MPI_INIT(ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)

    do
        if ( rank .eq. 0 ) then
            write(*, '(a)', advance='no') 'Enter the number of intervals: '
            read(*,*) num_rects
        endif

        ! sends value to all other processes
        call MPI_BCAST(num_rects, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)

        if (num_rects .le. 0) exit

        sum_i= 0.0d0
        interval = 1.0d0 / num_rects

        do i = rank+1, num_rects, numprocs
            x = interval * (dble(i) - 0.5d0)
            sum_i = sum_i+ f(x)
            ! print *, 'h: ', interval, 'rank: ', rank, ', x: ', x, ', sum:', sum_i
        enddo
        local_sum = interval * sum_i
        ! print *, 'rank: ', rank, ', local_sum: ', local_sum

        call MPI_REDUCE(local_sum, estimated_pi, 1, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, ierr)

        if (rank .eq. 0) then
            print *, 'Estimated PI: ', estimated_pi, 'Error: ', abs(estimated_pi - PI25DT)
            print *, ' '
        endif

    end do

    call MPI_FINALIZE(ierr)

end program main


      PROGRAM xgauher
C     driver for routine gauher
      INTEGER NP
      REAL SQRTPI
      PARAMETER(NP=64,SQRTPI=1.7724539)
      INTEGER i,n
      REAL func,check,xx,x(NP),w(NP)
1     write(*,*) 'Enter N'
      read(*,*,END=99) n
      call gauher(x,w,n)
      write(*,'(/1x,t3,a,t10,a,t22,a/)') '#','X(I)','W(I)'
      do 11 i=1,n
        write(*,'(1x,i2,2e14.6)') i,x(i),w(i)
11    continue
      check=0.
      do 12 i=1,n
        check=check+w(i)
12    continue
      write(*,'(/1x,a,e15.7,a,e15.7)') 'Check value:',check,
     *  '  should be:',SQRTPI
C     demonstrate the use of GAUHER for an integral
      xx=0.0
      do 13 i=1,n
        xx=xx+w(i)*func(x(i))
13    continue
      write(*,'(/1x,a,f12.6)') 'Integral from GAUHER:',xx
      write(*,'(1x,a,f12.6)') 'Actual value:        ',SQRTPI*exp(-.25)
      go to 1
99    stop
      END
      REAL FUNCTION func(x)
      REAL x
      func=cos(x)
      END

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


module compare_floats
contains

  ! Floating point number comparisons can be rather unreliable and tend to
  !  break at unexpected times.
  ! Ideas here are inspired by this page:
  !  http://www.cygnus-software.com/papers/comparingfloats/comparingfloats.htm
  logical function feq(f1, f2)
    use real_kind

    implicit none
    real(double) :: f1, f2
    real(double), parameter :: abserr = 1d-300
    real(double), parameter :: relerr = 1d-24
    !logical :: t1, t2, t3
    !
    !t1 = f1 == f2
    !t2 = abs(f1-f2) < abserr
    !t3 = abs( (f1-f2)/max(f1,f2) ) < relerr
    !if (t1 /= t2 .or. t1 /= t3 .or. t2/=t3) then
    !   print *, t1, t2, t3, f1-f2
    !end if

    ! Check absolute difference
    if (f1 == f2 .or. abs(f1-f2) < abserr) then
       feq = .true.
       return
    end if

    ! Check relative difference
    if ( abs( (f1-f2)/max(f1,f2) ) < relerr) then
       feq = .true.
       return
    end if

    ! Difference too large - return
    feq = .false.
    return

  end function feq

  logical function nfeq(f1, f2)
    use real_kind
    implicit none
    real(double) :: f1, f2

    nfeq = .not. feq(f1, f2)
  end function nfeq

end module compare_floats


module fourier

! Calculates the discrete Fourier transform using the simple direct but slow
! O(n^2) algorithm.

use types, only: dp
use constants, only: i_, pi
use utils, only: stop_error, assert
implicit none
private
public dft, idft, fft, fft_vectorized, fft_pass, fft_pass_inplace, &
    fft_vectorized_inplace, calculate_factors, ifft_pass, fft2_inplace, &
    fft3_inplace, fft3_inplace_transpose, ifft3_inplace, ifft1_inplace

contains

function dft(x) result(p)
! Compute the one-dimensional discrete Fourier transform
real(dp), intent(in) :: x(:)
complex(dp) :: p(size(x))
complex(dp) :: F(size(x), size(x))
integer :: N, i, j
N = size(x)
forall(i=0:N-1, j=0:N-1, i >= j) F(i+1, j+1) = exp(-2*pi*i_*i*j / N)
forall(i=1:N, j=1:N, i < j) F(i, j) = F(j, i)
p = matmul(F, x)
end function

function idft(p) result(x)
! Compute the one-dimensional inverse discrete Fourier transform
! The normalization is such that idft(dft(x)) == x to within numerical
! accuracy.
complex(dp), intent(in) :: p(:)
complex(dp) :: x(size(p))
complex(dp) :: F(size(p), size(p))
integer :: N, i, j
N = size(p)
forall(i=0:N-1, j=0:N-1, i >= j) F(i+1, j+1) = exp(+2*pi*i_*i*j/ N)
forall(i=1:N, j=1:N, i < j) F(i, j) = F(j, i)
x = matmul(F, p) / N
end function

recursive function fft(x) result(p)
! A recursive implementation of the 1D Cooley-Tukey FFT
real(dp), intent(in) :: x(:)
complex(dp) :: p(size(x)), X_even(size(x)/2), X_odd(size(x)/2)
complex(dp) :: factor(size(x))
integer :: N, i
N = size(x)
if (iand(N, N-1) /= 0) call stop_error("size of x must be a power of 2")
if (N <= 4) then
    p = dft(x)
else
    X_even = fft(x(::2))
    X_odd = fft(x(2::2))
    forall(i=0:N-1) factor(i+1) = exp(-2*pi*i_*i/N)
    p = [X_even + factor(:N / 2) * X_odd, X_even + factor(N / 2+1:) * X_odd]
end if
end function

subroutine dft_vec(Ns, N, x, p)
! Compute the one-dimensional discrete Fourier transform on each row of 'x'
! separately.
integer, intent(in) :: Ns, N
complex(dp), intent(in) :: x(Ns, N)
complex(dp), intent(out) :: p(Ns, N)
complex(dp) :: F(N, N)
integer :: i, j
forall(i=0:N-1, j=0:N-1, i >= j) F(i+1, j+1) = exp(-2*pi*i_*i*j / N)
forall(i=1:N, j=1:N, i < j) F(i, j) = F(j, i)
p = matmul(x, F)
end subroutine

subroutine fft_step(Ns, Nmin, x, p)
integer, intent(in) :: Ns, Nmin
complex(dp), intent(in) :: x(Ns, Nmin)
complex(dp), intent(out) :: p(Ns/2, Nmin*2)
complex(dp) :: tmp
integer :: i
do i = 1, Nmin
    !tmp = exp(-pi*i_*(i-1)/Nmin)
    ! The same as the previous line, just faster:
    tmp = cos(pi*(i-1)/Nmin) - i_*sin(pi*(i-1)/Nmin)
    p(:,      i) = x(:Ns/2, i) + tmp * x(Ns/2+1:, i)
    p(:, Nmin+i) = x(:Ns/2, i) - tmp * x(Ns/2+1:, i)
end do
end subroutine

subroutine fft_vectorized_inplace(x)
! A vectorized, non-recursive version of the Cooley-Tukey FFT
complex(dp), intent(inout), target :: x(:)
complex(dp), target :: p(size(x))
integer :: N, Nmin, Ns
logical :: p_is_result
N = size(x)
if (iand(N, N-1) /= 0) call stop_error("size of x must be a power of 2")
Nmin = 1
Ns = N
p_is_result = .true.
do while (Nmin < N)
    if (p_is_result) then
        call fft_step(Ns, Nmin, x, p)
    else
        call fft_step(Ns, Nmin, p, x)
    end if
    Nmin = Nmin * 2
    Ns = Ns / 2
    p_is_result = .not. p_is_result
end do
if (.not. p_is_result) x = p
end subroutine

function fft_vectorized(x) result(p)
real(dp), intent(in) :: x(:)
complex(dp) :: p(size(x))
p = x
call fft_vectorized_inplace(p)
end function

subroutine precalculate_coeffs(wa)
! Precalculates all cos/sin factors
complex(dp), intent(out) :: wa(:)
integer :: n, k, i, idx
n = size(wa)
k = n / 2
idx = 1
do while (k > 0)
    wa(idx) = 1
    do i = 1, k
        idx = idx + 1
        ! Equivalent to exp(-i_*i*pi/k) but faster:
        wa(idx) = cos(i*pi/k) - i_ * sin(i*pi/k)
    end do
    k = k/2
end do
end subroutine

subroutine precalculate_angles(fac, wa)
! Precalculates all cos/sin factors
integer, intent(in) :: fac(:)
complex(dp), intent(out) :: wa(:)
integer :: fi, n, i, j, k1, i1, ip, l1, l2, ld
real(dp) :: arg, argld
n = size(wa)
I = 1
L1 = 1
do K1 = 1, size(fac)
    IP = fac(K1)
    LD = 0
    L2 = L1*IP
    do J = 1, IP-1
        I1 = I
        wa(i) = 1
        LD = LD+L1
        ARGLD = 2*pi*LD/n
        do FI = 1, N/L2
           I = I+1
           ARG = FI*ARGLD
           wa(i) = cos(arg) - i_ * sin(arg)
        end do
        if (IP > 5) wa(i1) = wa(i)
    end do
    L1 = L2
end do
end subroutine

subroutine passf2(IDO, L1, CC, CH, WA1)
! FFT pass of factor 2
integer, intent(in) :: IDO, L1
complex(dp), intent(in) :: CC(IDO, 2, L1), WA1(:)
complex(dp), intent(out) :: CH(IDO, L1, 2)
integer :: I, K
do K = 1, L1
    do I = 1, IDO
        CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
        CH(I,K,2) = WA1(I)*(CC(I,1,K)-CC(I,2,K))
    end do
end do
end subroutine

subroutine passf3(IDO, L1, CC, CH, WA1, WA2)
integer, intent(in) :: IDO, L1
complex(dp), intent(in) :: CC(IDO,3,L1), WA1(:), WA2(:)
complex(dp), intent(out) :: CH(IDO,L1,3)
complex(dp) :: C1, C2, C3
integer :: I, K
real(dp), parameter :: taur = -0.5_dp, taui = -sqrt(3._dp)/2
do K=1,L1
    do I=1,IDO
        CH(I,K,1) = CC(I,1,K)+CC(I,2,K)+CC(I,3,K)
        C1 = CC(I,1,K) + TAUR * (CC(I,2,K)+CC(I,3,K))
        C3 = TAUI * (CC(I,2,K)-CC(I,3,K))
        ! The same as C2 = C3 * exp(i_*pi/2) but faster:
        C2 = - aimag(C3) + i_ * real(C3, dp)
        CH(I,K,2) = WA1(I) * (C1 + C2)
        CH(I,K,3) = WA2(I) * (C1 - C2)
    end do
end do
end subroutine

subroutine passf4(IDO, L1, CC, CH, WA1, WA2, WA3)
integer, intent(in) :: IDO, L1
complex(dp), intent(in) :: CC(IDO, 4, L1), WA1(:), WA2(:), WA3(:)
complex(dp), intent(out) :: CH(IDO, L1, 4)
integer :: I, K
do K = 1, L1
    do I = 1, IDO
        CH(I,K,1) =          (CC(I,1,K) + CC(I,3,K) +   (CC(I,2,K) + CC(I,4,K)))
        CH(I,K,2) = WA1(I) * (CC(I,1,K) - CC(I,3,K) -i_*(CC(I,2,K) - CC(I,4,K)))
        CH(I,K,3) = WA2(I) * (CC(I,1,K) + CC(I,3,K) -   (CC(I,2,K) + CC(I,4,K)))
        CH(I,K,4) = WA3(I) * (CC(I,1,K) - CC(I,3,K) +i_*(CC(I,2,K) - CC(I,4,K)))
    end do
end do
end subroutine

subroutine passf5(IDO, L1, CC, CH, WA1, WA2, WA3, WA4)
integer, intent(in) :: IDO, L1
complex(dp), intent(in) :: CC(IDO, 5, L1), WA1(:), WA2(:), WA3(:), WA4(:)
complex(dp), intent(out) :: CH(IDO, L1, 5)
complex(dp) :: C2, C3, C4, C5, C4b, C5b
integer :: I, K
real(dp), parameter :: tr11 =  cos(2*pi/5)
real(dp), parameter :: ti11 = -sin(2*pi/5)
real(dp), parameter :: tr12 =  cos(4*pi/5)
real(dp), parameter :: ti12 = -sin(4*pi/5)
do K = 1, L1
    do I = 1, IDO
        CH(I,K,1) = CC(I,1,K) + CC(I,2,K) + CC(I,3,K) + CC(I,4,K) + CC(I,5,K)
        C2 = CC(I,1,K) + TR11*(CC(I,2,K)+CC(I,5,K)) + TR12*(CC(I,3,K)+CC(I,4,K))
        C3 = CC(I,1,K) + TR12*(CC(I,2,K)+CC(I,5,K)) + TR11*(CC(I,3,K)+CC(I,4,K))
        C4 = TI12*(CC(I,2,K)-CC(I,5,K)) - TI11*(CC(I,3,K)-CC(I,4,K))
        C5 = TI11*(CC(I,2,K)-CC(I,5,K)) + TI12*(CC(I,3,K)-CC(I,4,K))
        C4b = aimag(C4) - i_*real(C4, dp)
        C5b = aimag(C5) - i_*real(C5, dp)
        CH(I,K,2) = WA1(I) * (C2 - C5b)
        CH(I,K,3) = WA2(I) * (C3 - C4b)
        CH(I,K,4) = WA3(I) * (C3 + C4b)
        CH(I,K,5) = WA4(I) * (C2 + C5b)
    end do
end do
end subroutine

subroutine passf(NAC, IDO, IP, L1, IDL1, C, CH_, WA)
! Works for any odd IP
integer, intent(out) :: NAC
integer, intent(in) :: IDO, IP, L1, IDL1
complex(dp), intent(in) :: WA(:)
complex(dp), intent(inout), target :: C(:), CH_(:)
complex(dp), pointer :: CC(:,:,:), C1(:, :, :), C2(:, :), CH(:, :, :), CH2(:, :)
integer :: I, K, idij, idj, idl, idlj, idp, ik, inc, ipp2, &
    ipph, j, jc, l, lc, nt
CC(1:IDO,1:IP,1:L1) => C
C1(1:IDO,1:L1,1:IP) => C
C2(1:IDL1,1:IP) => C
CH(1:IDO,1:L1,1:IP) => CH_
CH2(1:IDL1,1:IP) => CH_
NT = IP*IDL1
IPP2 = IP+2
IPPH = (IP+1)/2
IDP = IP*IDO
do J = 2, IPPH
    JC = IPP2-J
    CH(:,:,J ) = CC(:,J,:) + CC(:,JC,:)
    CH(:,:,JC) = CC(:,J,:) - CC(:,JC,:)
end do
CH(:,:,1) = CC(:,1,:)
IDL = 1-IDO
INC = 0
do L=2,IPPH
    LC = IPP2-L
    IDL = IDL+IDO
    do IK=1,IDL1
        C2(IK,L ) = CH2(IK,1) + real(WA(IDL),dp) * CH2(IK,2 )
        C2(IK,LC) =          + aimag(WA(IDL))    * CH2(IK,IP)
    end do
    IDLJ = IDL
    INC = INC+IDO
    do J=3,IPPH
        JC = IPP2-J
        IDLJ = IDLJ+INC
        if (IDLJ > IDP) IDLJ = IDLJ-IDP
        do IK=1,IDL1
            C2(IK,L ) = C2(IK,L ) +  real(WA(IDLJ),dp) * CH2(IK,J )
            C2(IK,LC) = C2(IK,LC) + aimag(WA(IDLJ))    * CH2(IK,JC)
        end do
    end do
end do
do J = 2, IPPH
    CH2(:,1) = CH2(:,1)+CH2(:,J)
end do
do J=2,IPPH
    JC = IPP2-J
    do IK=1,IDL1
        CH2(IK,J ) = C2(IK,J) - aimag(C2(IK,JC)) + i_ * real(C2(IK,JC), dp)
        CH2(IK,JC) = C2(IK,J) + aimag(C2(IK,JC)) - i_ * real(C2(IK,JC), dp)
    end do
end do
NAC = 1
if (IDO == 1) return
NAC = 0
C2(:,1) = CH2(:,1)
C1(1,:,:) = CH(1,:,:)
IDJ = 1-IDO
do J=2,IP
    IDJ = IDJ+IDO
    do K=1,L1
        IDIJ = IDJ
        do I=2,IDO
            IDIJ = IDIJ+1
            C1(I,K,J) = WA(IDIJ)*CH(I,K,J)
        end do
    end do
end do
end subroutine

subroutine calculate_factors(n, fac)
integer, intent(in) :: n
integer, intent(out), allocatable :: fac(:)
! TODO: add checks that we don't go over MAX_LENGTH below:
integer, parameter :: MAX_LENGTH = 1000
integer :: fac_tmp(MAX_LENGTH)
integer, parameter :: NTRYH(4) = [3, 4, 2, 5]
integer :: NL, NF, I, J, NTRY, IB, NQ, NR
if (n == 1) then
    allocate(fac(1))
    fac(1) = 1
    return
end if
NL = N
NF = 0
J = 0
NTRY = 0
do while (NL /= 1)
    J = J+1
    if (J <= 4) then
        NTRY = NTRYH(J)
    else
        NTRY = NTRY+2
    end if
    ! Divide by NTRY as many times as we can:
    do while (NL /= 1)
        NQ = NL/NTRY
        NR = NL-NTRY*NQ
        if (NR /= 0) exit
        NF = NF+1
        fac_tmp(NF) = NTRY
        NL = NQ
        if (NTRY == 2 .and. NF > 1) then
            do I = 2, NF
                IB = NF-I+2
                fac_tmp(IB) = fac_tmp(IB-1)
            end do
            fac_tmp(1) = 2
        end if
    end do
end do
allocate(fac(NF))
fac = fac_tmp(:NF)
end subroutine

subroutine fft_pass_inplace(x)
complex(dp), intent(inout) :: x(:)
complex(dp), dimension(size(x)) :: angles, CH
integer, allocatable :: fac(:)
integer :: n
n = size(x)
call calculate_factors(n, fac)
call precalculate_angles(fac, angles)
call calc_fft(n, x, CH, angles, fac)
end subroutine

subroutine calc_fft(N,C,CH,WA,IFAC)
integer, intent(in) :: N
complex(dp), intent(inout) :: C(:)
complex(dp), intent(out) :: CH(:)
complex(dp), intent(in), target :: WA(:)
integer, intent(in) :: IFAC(:)
integer :: k1, l1, na, iw, ip, l2, ido, idl1, nac
complex(dp), pointer :: w(:, :)
NA = 0
L1 = 1
IW = 1
do K1 = 1, size(ifac)
    IP = IFAC(K1)
    L2 = IP*L1
    IDO = N/L2
    w(1:IDO,1:IP-1) => WA(IW:IW+(IP-1)*IDO-1)
    select case(IP)
    case (4)
        if (NA == 0) then
            call passf4(IDO,L1,C,CH,w(:, 1),w(:, 2),w(:, 3))
        else
            call passf4(IDO,L1,CH,C,w(:, 1),w(:, 2),w(:, 3))
        end if
    case (2)
        if (NA == 0) then
            call passf2(IDO,L1,C,CH,w(:, 1))
        else
            call passf2(IDO,L1,CH,C,w(:, 1))
        end if
    case (3)
        if (NA == 0) then
            call passf3(IDO,L1,C,CH,w(:, 1),w(:, 2))
        else
            call passf3(IDO,L1,CH,C,w(:, 1),w(:, 2))
        end if
    case (5)
        if (NA == 0) then
            call passf5(IDO,L1,C,CH,w(:, 1),w(:, 2),w(:, 3),w(:, 4))
        else
            call passf5(IDO,L1,CH,C,w(:, 1),w(:, 2),w(:, 3),w(:, 4))
        end if
    case default
        IDL1 = IDO*L1
        if (NA == 0) then
            call passf(NAC, IDO, IP, L1, IDL1, C, CH, WA(IW:IW+(IP-1)*IDO-1))
        else
            call passf(NAC, IDO, IP, L1, IDL1, CH, C, WA(IW:IW+(IP-1)*IDO-1))
        end if
        if (NAC == 0) NA = 1-NA
    end select
    NA = 1-NA
    L1 = L2
    IW = IW+(IP-1)*IDO
end do
if (NA /= 0) C = CH
end subroutine

function fft_pass(x) result(p)
real(dp), intent(in) :: x(:)
complex(dp) :: p(size(x))
p = x
call fft_pass_inplace(p)
end function

function ifft_pass(x) result(p)
! Inverse FFT, defined as: ifft(fft(x))/n = x, i.e. don't forget to divide by n
complex(dp), intent(in) :: x(:)
complex(dp) :: p(size(x))
p = conjg(x)
call fft_pass_inplace(p)
p = conjg(p)
end function

function ifft_pass2(x) result(p)
! Inverse FFT, alternative implementation
! Seems to be about as fast as ifft_pass()
complex(dp), intent(in) :: x(:)
complex(dp) :: p(size(x))
p = aimag(x) + i_ * real(x, dp)
call fft_pass_inplace(p)
p = aimag(p) + i_ * real(p, dp)
end function

function ifft_pass3(x) result(p)
! Inverse FFT, alternative implementation
! Seems to be slower than ifft_pass()
complex(dp), intent(in) :: x(:)
complex(dp) :: p(size(x))
p = x
call fft_pass_inplace(p)
p = [p(1), p(size(x):2:-1)]
end function

subroutine fft2_inplace(x)
complex(dp), intent(inout) :: x(:, :)
integer :: i
do i = 1, size(x, 2)
    call fft_pass_inplace(x(:, i))
end do
do i = 1, size(x, 1)
    call fft_pass_inplace(x(i, :))
end do
end subroutine

subroutine global_transpose(w, h, x, y)
integer, intent(in) :: w, h
complex(dp), intent(in) :: x(w, h)
complex(dp), intent(out) :: y(h, w)
y = transpose(x)
end subroutine

subroutine fft3_inplace(x)
complex(dp), intent(inout) :: x(:, :, :)
complex(dp), dimension(size(x, 1)) :: angles1, CH1
complex(dp), dimension(size(x, 2)) :: angles2, CH2, x2
complex(dp), dimension(size(x, 3)) :: angles3, CH3, x3
integer, allocatable :: fac1(:), fac2(:), fac3(:)
integer :: i, j
call calculate_factors(size(x, 1), fac1)
call precalculate_angles(fac1, angles1)
call calculate_factors(size(x, 2), fac2)
call precalculate_angles(fac2, angles2)
call calculate_factors(size(x, 3), fac3)
call precalculate_angles(fac3, angles3)
do j = 1, size(x, 3)
    do i = 1, size(x, 2)
        call calc_fft(size(x, 1), x(:, i, j), CH1, angles1, fac1)
    end do
end do
do j = 1, size(x, 3)
    do i = 1, size(x, 1)
        x2 = x(i, :, j)
        call calc_fft(size(x, 2), x2, CH2, angles2, fac2)
        x(i, :, j) = x2
    end do
end do
do j = 1, size(x, 2)
    do i = 1, size(x, 1)
        x3 = x(i, j, :)
        call calc_fft(size(x, 3), x3, CH3, angles3, fac3)
        x(i, j, :) = x3
    end do
end do
end subroutine

subroutine fft3_inplace_transpose(xyz)
! The same as fft3_inplace() but using a global transpose instead
complex(dp), intent(inout) :: xyz(:, :, :)
complex(dp), dimension(size(xyz, 1)) :: angles1, CH1
complex(dp), dimension(size(xyz, 2)) :: angles2, CH2
complex(dp), dimension(size(xyz, 3)) :: angles3, CH3
complex(dp) :: yzx(size(xyz, 2), size(xyz, 3) * size(xyz, 1))
complex(dp) :: zxy(size(xyz, 3), size(xyz, 1) * size(xyz, 2))
integer, allocatable :: fac1(:), fac2(:), fac3(:)
integer :: i, j
call calculate_factors(size(xyz, 1), fac1)
call precalculate_angles(fac1, angles1)
call calculate_factors(size(xyz, 2), fac2)
call precalculate_angles(fac2, angles2)
call calculate_factors(size(xyz, 3), fac3)
call precalculate_angles(fac3, angles3)
do j = 1, size(xyz, 3)
    do i = 1, size(xyz, 2)
        call calc_fft(size(xyz, 1), xyz(:, i, j), CH1, angles1, fac1)
    end do
end do
call global_transpose(size(xyz, 1), size(xyz)/size(xyz, 1), xyz, yzx)
do i = 1, size(yzx, 2)
    call calc_fft(size(yzx, 1), yzx(:, i), CH2, angles2, fac2)
end do
call global_transpose(size(yzx, 1), size(yzx, 2), yzx, zxy)
do i = 1, size(zxy, 2)
    call calc_fft(size(zxy, 1), zxy(:, i), CH3, angles3, fac3)
end do
call global_transpose(size(zxy, 1), size(zxy, 2), zxy, xyz)
end subroutine

subroutine ifft3_inplace(x)
! Inverse FFT, defined as: ifft3(fft3(x))/n = x,
! i.e. don't forget to divide by n, where n=n1*n2*n3
complex(dp), intent(inout) :: x(:, :, :)
x = conjg(x)
call fft3_inplace(x)
x = conjg(x)
end subroutine

subroutine ifft1_inplace(x)
! Inverse FFT, defined as: ifft1(fft1(x))/n = x,
! i.e. don't forget to divide by n, where n=n1*n2*n3
complex(dp), intent(inout) :: x(:)
x = conjg(x)
call fft_pass_inplace(x)
x = conjg(x)
end subroutine

end module


program pi_computation

implicit none
include 'mpif.h'

      integer :: ierr, size, rank
      integer :: N, iff, ill, i
      integer, parameter :: iroot = 0
      real :: dx, x, summ, integrand, t_sum

      N = 20

      call MPI_INIT(ierr)

      call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)

      if (rank.gt.iroot) then

                dx = 1.d0/N
                call decompose(N, size, rank, iff, ill)
                summ = 0
                do i = iff, ill
                        x = (real(i) - 0.5)*dx
                        summ = summ + integrand(x)*dx
                end do
      else
                summ = 0
      end if

      call MPI_REDUCE(summ,t_sum, 1, MPI_REAL, MPI_SUM, iroot, MPI_COMM_WORLD, ierr)

      if(rank.eq.iroot) then
                print *, 'The computed pi value:', t_sum
      end if

      call MPI_FINALIZE(ierr)

end program

!-------------Subroutine decompose ----------------------

subroutine decompose(n, size, rank, iff, ill)

        implicit none
        integer :: n, size, rank, iff, ill, neven

        neven = n/(size-1)
        iff = (rank-1)*neven + 1
        ill = rank*neven

        if (rank.eq.size-1) then
                ill = rank*neven + mod(n, size-1)
        end if

end subroutine
!--------------------------------------------------------
function integrand(x)

        implicit none
        real :: x, integrand

        integrand = 4.d0/(1.d0 + x**2)

end function


 implicit none

 integer, parameter :: nmax=10

 integer :: i,n
 real(8) :: a(0:nmax),x

 real(8), external :: poly

 print*,'Order of the polynomial'; read*,n
 if (n > nmax) then
   print*,'Order higher than nmax'; stop
 endif

 do i=0,n
   print*,'Give coefficient ',i; read*,a(i)
 enddo

 print*,'Evaluate at x-value:'; read*,x
 print*,'Polynomial value is: ',poly(n,a(0:n),x)

 end

 function poly(n,a,x)

 implicit none

 integer :: i,n
 real(8) :: poly,a(0:n),x

 poly=0.0d0
 do i=0,n
   poly=poly+a(i)*x**i
 enddo

 end function poly


module constants
	! Some constant parameters
	real, parameter :: PI = 4*atan(1.0)

end module constants


!!## MODULE: FUNCTION  FUN_Sequence
MODULE FUN_Sequence

!!### PURPOSE
!! Construct an arithmetic sequence for single and
!! double precision reals and default integers.

!!### HISTORY
! 1. [nr] Author=Numerical Recipes
!
! 2. [waw] Reorganizer=William Wieselquist
!          Contact    =william.wieselquist@gmail.com
!          Year       =2006

!!### USAGE
!
!! The call
!
!         y = Sequence( a , b , n )
!
!! returns an arithmetic sequence of length <n>.
!
!         y = [ a , a + b , a + 2*b , ... , a + (n-1)*b ]
!

!!### DETAILS
!! The global variable, <MAX_DIRECT_SEQUENCE>, controls at what value
!! of <n> the evaluation of the arithmetic sequence turns ugly.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp,KIND_I !!((01-A-KND_IntrinsicTypes.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### PROCEDURE OVERLOADING
INTERFACE Sequence
 MODULE PROCEDURE Sequence_Rsp
 MODULE PROCEDURE Sequence_Rdp
 MODULE PROCEDURE Sequence_I
END INTERFACE

!!### GLOBAL VARIABLES
!! @ maximum number of elements allowed to calculate a
!!   direct sequence the easy way.
INTEGER :: MAX_DIRECT_SEQUENCE = 64

!!### PUBLIC ACCESS LIST
PUBLIC :: Sequence
PUBLIC :: MAX_DIRECT_SEQUENCE

!!## MODULE PROCEDURES
CONTAINS

!!### PURE FUNCTION: Sequence_Rsp
PURE FUNCTION Sequence_Rsp( first , increment , n ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp         !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_Sequence_R.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_Sequence.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: Sequence_Rdp
PURE FUNCTION Sequence_Rdp( first , increment , n ) RESULT(y)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp         !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_Sequence_R.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_Sequence.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: Sequence_I
PURE FUNCTION Sequence_I( first , increment , n ) RESULT(y)
INCLUDE "03-A-FUN_Sequence_I.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_Sequence.f90.bdy"
!!--end--
END FUNCTION

END MODULE


c  intrinsic-f2c-z.f
c
c Test double complex intrinsics Z*.
c These functions are f2c extensions
c
c     David Billinghurst <David.Billinghurst@riotinto.com>
c
      double complex z, a
      double precision x
      logical fail
      intrinsic zabs, zcos, zexp, zlog, zsin, zsqrt
      common /flags/ fail
      fail = .false.

c     ZABS - Absolute value
      z = (3.0d0,-4.0d0)
      x = 5.0d0
      call c_d(ZABS(z),x,'ZABS(double complex)')
      call p_d_z(ZABS,z,x,'ZABS')

c     ZCOS - Cosine
      z = (3.0d0,1.0d0)
      a = (-1.52763825012d0,-0.165844401919)
      call c_z(ZCOS(z),a,'ZCOS(double complex)')
      call p_z_z(ZCOS,z,a,'ZCOS')

c     ZEXP - Exponential
      z = (3.0d0,1.0d0)
      a = (10.8522619142d0,16.9013965352)
      call c_z(ZEXP(z),a,'ZEXP(double complex)')
      call p_z_z(ZEXP,z,a,'ZEXP')

c     ZLOG - Natural logarithm
      call c_z(ZLOG(a),z,'ZLOG(double complex)')
      call p_z_z(ZLOG,a,z,'ZLOG')

c     ZSIN - Sine
      z = (3.0d0,1.0d0)
      a = (0.217759551622d0,-1.1634403637d0)
      call c_z(ZSIN(z),a,'ZSIN(double complex)')
      call p_z_z(ZSIN,z,a,'ZSIN')

c     ZSQRT - Square root
      z = (0.0d0,-4.0d0)
      a = sqrt(2.0d0)*(1.0d0,-1.0d0)
      call c_z(ZSQRT(z),a,'ZSQRT(double complex)')
      call p_z_z(ZSQRT,z,a,'ZSQRT')

      if ( fail ) call abort()
      end

      subroutine failure(label)
c     Report failure and set flag
      character*(*) label
      logical fail
      common /flags/ fail
      write(6,'(a,a,a)') 'Test ',label,' FAILED'
      fail = .true.
      end

      subroutine c_z(a,b,label)
c     Check if DOUBLE COMPLEX a equals b, and fail otherwise
      double complex a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0e-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_d(a,b,label)
c     Check if DOUBLE PRECISION a equals b, and fail otherwise
      double precision a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0d-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine p_z_z(f,x,a,label)
c     Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
      double complex f,x,a
      character*(*) label
      call c_z(f(x),a,label)
      end

      subroutine p_d_z(f,x,a,label)
c     Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
      double precision f,x
      double complex a
      character*(*) label
      call c_d(f(x),a,label)
      end


      REAL FUNCTION PTREGD (PX,PY,PZ, NSZ, XA,YA,ZA)

C  PTREGD computes the minimum distance from a 3D point to a planar
C  3D region.

C Input parameters:
C   PX,PY,PZ : point for which distance is found.
C   NSZ      : number of points in region.
C   XA,YA,ZA : coordinates of planar region.

      INTEGER    NSZ, IA, IB, SIDE

      REAL       PX,PY,PZ, XA(NSZ),YA(NSZ),ZA(NSZ)
      REAL       XN,YN,ZN, PTMIN, EDGMIN
      REAL       SEGA,SEGB,SEGC, D1,D2, ABCP, DTMP,VECL, PLDIST

      IF (NSZ .LT. 3) THEN
         CALL UNMSG ('Degenerate region passed to PTREGD.')
      ENDIF

      CALL INVOL (PX,PY,PZ, NSZ, XA,YA,ZA, SIDE, PLDIST)
      IF (SIDE .LE. 2) THEN
C  Distance is simply distance of point from containing plane
         PTREGD = PLDIST
         RETURN
      ENDIF

C  Distance is minimum of distances from points and from individual edges

C  Get point minimum:
      PTMIN = 1E38
      DO 100 IA = 1,NSZ
         DTMP = VECL (PX-XA(IA), PY-YA(IA), PZ-ZA(IA) )
         IF (DTMP .LT. PTMIN) PTMIN = DTMP
100   CONTINUE

C  Get edge minimum:
      EDGMIN = 1E38
      DO 200 IA = 1,NSZ
         IB = MOD(IA, NSZ) + 1
C  Determine if point is between the two planes that contain the
C  endpoints of the segment, and are normal to it.  If not, ignore -
C  handled by point minimum.  If so, distance is that from point to
C  containing line.

C  attitude of planes:
         SEGA = XA(IA) - XA(IB)
         SEGB = YA(IA) - YA(IB)
         SEGC = ZA(IA) - ZA(IB)
C  d-coefficient of each plane:
         D1 = -(SEGA*XA(IA) + SEGB*YA(IA) + SEGC*ZA(IA))
         D2 = -(SEGA*XA(IB) + SEGB*YA(IB) + SEGC*ZA(IB))
C  ABC terms for px,py,pz:
         ABCP = SEGA*PX + SEGB*PY + SEGC*PZ
         IF ( (ABCP + D1) * (ABCP + D2) .LT. 0.0 ) THEN
C  Opposite signs imply point is between planes - get distance from
C  point to line.
            CALL PTLNDS (PX,PY,PZ, SEGA,SEGB,SEGC,
     1                   XA(IA),YA(IA),ZA(IA), XN,YN,ZN, DTMP)
            IF (DTMP .LT. EDGMIN) EDGMIN = DTMP
         ENDIF
200   CONTINUE

      PTREGD = MIN (PTMIN, EDGMIN)

      END