! { dg-do run }
! { dg-options "-fno-inline" }
!
! SUM as initialization expression.
!
! This test compares results of simplifier of SUM
! with the corresponding inlined or library routine(s).
!

  IMPLICIT NONE

  INTEGER, PARAMETER :: imatrix(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2, 4] )
  INTEGER, PARAMETER :: imatrix_sum = SUM (imatrix)
  INTEGER, PARAMETER :: imatrix_sum_d1(4) = SUM (imatrix, dim=1)
  INTEGER, PARAMETER :: imatrix_sum_d2(2) = SUM (imatrix, dim=2)
  LOGICAL, PARAMETER :: i_equal_sum = ALL ([SUM( imatrix_sum_d1 ) ==  SUM ( imatrix_sum_d2 ), &
                                            SUM( imatrix_sum_d1 ) == imatrix_sum])
  LOGICAL, PARAMETER :: i_empty_sum = SUM(imatrix, mask=.FALSE.) == 0

  REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7, 8.8 ], [2, 4] )
  REAL, PARAMETER :: rmatrix_sum = SUM (rmatrix)
  REAL, PARAMETER :: rmatrix_sum_d1(4) = SUM (rmatrix, dim=1)
  REAL, PARAMETER :: rmatrix_sum_d2(2) = SUM (rmatrix, dim=2)
  LOGICAL, PARAMETER :: r_equal_sum = ALL ([SUM( rmatrix_sum_d1 ) ==  SUM ( rmatrix_sum_d2 ), &
                                            SUM( rmatrix_sum_d1 ) == rmatrix_sum])
  LOGICAL, PARAMETER :: r_empty_sum = SUM(rmatrix, mask=.FALSE.) == 0.0

  IF (.NOT. ALL ([i_equal_sum, i_empty_sum])) STOP 1
  IF (.NOT. ALL ([r_equal_sum, r_empty_sum])) STOP 2

  CALL ilib (imatrix, imatrix_sum)
  CALL ilib_with_dim (imatrix, 1, imatrix_sum_d1)
  CALL ilib_with_dim (imatrix, 2, imatrix_sum_d2)
  CALL rlib (rmatrix, rmatrix_sum)
  CALL rlib_with_dim (rmatrix, 1, rmatrix_sum_d1)
  CALL rlib_with_dim (rmatrix, 2, rmatrix_sum_d2)

CONTAINS
  SUBROUTINE ilib (array, result)
    INTEGER, DIMENSION(:,:), INTENT(in) :: array
    INTEGER, INTENT(in) :: result
    IF (SUM(array) /= result) STOP 3
  END SUBROUTINE

  SUBROUTINE ilib_with_dim (array, dim, result)
    INTEGER, DIMENSION(:,:), INTENT(in) :: array
    INTEGER, INTENT(iN)                 :: dim
    INTEGER, DIMENSION(:), INTENT(in)   :: result
    IF (ANY (SUM (array, dim=dim) /= result)) STOP 4
  END SUBROUTINE

  SUBROUTINE rlib (array, result)
    REAL, DIMENSION(:,:), INTENT(in) :: array
    REAL, INTENT(in) :: result
    IF (ABS(SUM(array) - result) > 4e-6) STOP 5
  END SUBROUTINE

  SUBROUTINE rlib_with_dim (array, dim, result)
    REAL, DIMENSION(:,:), INTENT(in) :: array
    INTEGER, INTENT(iN)              :: dim
    REAL, DIMENSION(:), INTENT(in)   :: result
    IF (ANY (ABS(SUM (array, dim=dim) - result) > 4e-6)) STOP 6
  END SUBROUTINE
END


! **********************************************
!  Last updated: December 10, 2012
! **********************************************
!
! This subroutine computes the roots of a complex polynomial of degree N
! in any recursively defined polynomial basis. The general
! algorithm is outlined in:
!
! Fast Computation of Eigenvalues of Companion, Comrade and Related Matrices, BIT Numerical Mathematics 2012
!
! **************************************************************
!
! Input variables:
!
! BANDSWITCH   0 indicates no COEFFS are input, 1 indicates COEFFS are given
!
! N            degree of polynomial
!
! K            maximum length of the recursion
!
! POLY         array of dimension N+1 containing the coefficients
!              of the polynomial in terms of the basis elements
!
! COEFFS       array of dimension (N x K) containing the recursion
!	       coefficients of the basis elements, ignored if BANDSWITCH = 0
!
! Output variables:
!
! ROOTS         contains the computed roots, dimension N
!
! ITERATIONS   integer array storing the number of iterations per root calculation
!
! FLAG         reports the position of any instance where the algorithm
!              tried to divide by 0
!
! ***************************************************************

subroutine ZAVW2(BANDSWITCH,N,K,POLY,COEFFS,ROOTS,ITERATIONS,FLAG)

	implicit none

	integer, intent(in) :: BANDSWITCH,N,K
	integer, intent(inout) :: ITERATIONS(N),FLAG
	complex(kind(1d0)), intent(in) :: POLY(N+1),COEFFS(N,K)
	complex(kind(1d0)), intent(inout) :: ROOTS(N)

	FLAG = 0

	if(BANDSWITCH == 0)then

		call ZLR(N,POLY,ROOTS,ITERATIONS,FLAG)

	else if(BANDSWITCH == 1)then

		call ZBLR(N,K,POLY,COEFFS,ROOTS,ITERATIONS,FLAG)

	else

		write(*,*) "Not a valid argument for BANDSWITCH"
		write(*,*) ""
		return
	end if

end subroutine

! **************************************************************
!
! This subroutine calculates the roots using the companion matrix
!
! **************************************************************

subroutine ZLR(N,POLY,ROOTS,ITERATIONS,FLAG)

  implicit none

  integer, intent(in) :: N
  complex(kind(1d0)), intent(in) :: poly(N+1)
  complex(kind(1d0)), intent(inout) :: roots(N)
  integer, intent(out) :: iterations(N),flag
  integer :: stop_index,start_index,zero_index,ii,jj,kk,mm,it_count=0,it_max
  real(kind(1d0)) :: tolerance=1d-16,zero_point,diagonals,diag1,diag2,norm
  complex(kind(1d0)) :: trace,detm,disc,DET,shift1,shift2,rho(1)
  complex(kind(1d0)) :: Blocks(2,2,N),L

! Initialize and normalize blocks

	if(abs(poly(1)) == 0)then
		write(*,*) "Polynomial is of degree less than N!"
		flag = 1
		return
	end if

  do kk=2,N
	Blocks(1,1,kk) = -poly(kk)/poly(1)
	Blocks(1,2,kk) = complex(1d0,0d0)
	Blocks(2,1,kk) = complex(1d0,0d0)
	Blocks(2,2,kk) = complex(0d0,0d0)
  end do

  Blocks(1,2,N) = -poly(N+1)/poly(1)

  Blocks(1,1,1) = complex(0d0,0d0)
  Blocks(1,2,1) = complex(0d0,0d0)
  Blocks(2,1,1) = complex(0d0,0d0)
  Blocks(2,2,1) = complex(1d0,0d0)

! Main loop

  stop_index = N
  start_index = 2
  zero_index = 1
  it_max = 20*N
  it_count = 0
  flag = 0

  do mm=1,it_max

	! Zero check
	do ii=1,stop_index
		zero_point = abs(Blocks(2,1,stop_index+1-ii))

		if(ii>1)then
			diag2 = abs(Blocks(1,1,stop_index+2-ii)*Blocks(2,2,stop_index+1-ii))
		else
			diag2 = abs(Blocks(2,2,stop_index+1-ii))
		end if

		if(ii<stop_index)then
			diag1 = abs(Blocks(1,1,stop_index+1-ii)*Blocks(2,2,stop_index-ii))
		else
			diag1 = abs(Blocks(1,1,stop_index+1-ii))
		end if

		diagonals = diag1 + diag2

		if(zero_point < tolerance*diagonals)then
			zero_index = stop_index+1-ii
			Blocks(2,1,zero_index) = complex(0d0,0d0)

			! Deflate down if not at bottom
			if(zero_index<stop_index)then
				Blocks(1,1,zero_index+1) = Blocks(1,1,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(2,1,zero_index+1) = Blocks(2,1,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(2,2,zero_index) = complex(1d0,0d0)
				start_index = zero_index+1
			end if

			exit

		end if
	end do

	! zero at bottom
	if(zero_index==stop_index)then
		roots(zero_index) = Blocks(2,2,zero_index)

		iterations(N-zero_index+1) = it_count
		it_count = 0

		if(stop_index<=1)then
			exit
		end if

		! deflate up
		Blocks(2,1,zero_index-1) = Blocks(2,1,zero_index-1)*Blocks(1,1,zero_index)
		Blocks(2,2,zero_index-1) = Blocks(2,2,zero_index-1)*Blocks(1,1,zero_index)
		Blocks(1,1,zero_index) = complex(1d0,0d0)

		stop_index = stop_index-1

	! 2x2 case
	else if(stop_index==start_index)then
		! calculate eigenvalues using modified quadratic
		trace = Blocks(1,1,stop_index) + Blocks(2,2,stop_index)
		detm = Blocks(1,1,stop_index)*Blocks(2,2,stop_index) - Blocks(1,2,stop_index)*Blocks(2,1,stop_index)

		disc = sqrt(trace*trace - 4*detm)

		if(abs(trace-disc)<abs(trace+disc))then
			if(abs(trace+disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace+disc)/2
				shift2 = 2*detm/(trace+disc)
			end if
		else
			if(abs(trace-disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace-disc)/2
				shift2 = 2*detm/(trace-disc)
			end if
		end if

		! store eigenvalues
		roots(stop_index) = shift1
		Blocks(2,2,stop_index-1) = shift2

		iterations(N-stop_index) = 0
		it_count = 0

		stop_index = stop_index-1

	! more than one block
	else
		it_count = it_count + 1

		! shift calc
		trace = Blocks(2,2,stop_index-1)*Blocks(1,1,stop_index) + Blocks(2,2,stop_index)
		detm = Blocks(1,1,stop_index)*Blocks(2,2,stop_index) - Blocks(1,2,stop_index)*Blocks(2,1,stop_index)
		detm = Blocks(2,2,stop_index-1)*detm

		disc = sqrt(trace*trace - 4*detm)

		if(abs(trace-disc)<abs(trace+disc))then
			if(abs(trace+disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace+disc)/complex(2d0,0d0)
				shift2 = complex(2d0,0d0)*detm/(trace+disc)
			end if
		else
			if(abs(trace-disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace-disc)/complex(2d0,0d0)
				shift2 = complex(2d0,0d0)*detm/(trace-disc)
			end if
		end if

		! pick best shift
		if(mm == 0)then
			rho(1) = complex(dsqrt(2d0),dsqrt(2d0))
!		else if(mm == 2)then
!			rho(1) = complex(dsqrt(2d0),-dsqrt(2d0))
!		else if(mm == 3)then
!			rho(1) = complex(-dsqrt(2d0),dsqrt(2d0))
!		else if(mm == 4)then
!			rho(1) = complex(-dsqrt(2d0),-dsqrt(2d0))
		else if(mod(it_count,15) == 0)then
			call cnormalpoly(1,rho(1))
			rho(1) = rho(1)
			write(*,*) "Exceptional shift in LR!"
		else if(abs(Blocks(2,2,stop_index)-shift1)<abs(Blocks(2,2,stop_index)-shift2))then
			rho(1) = shift1
		else
			rho(1) = shift2
		end if

		! Build L
		if(abs(Blocks(1,1,start_index)-rho(1)) == 0)then
			if(abs(rho(1)) == 0)then
				call cnormalpoly(1,rho(1))
				rho(1) = rho(1)/abs(rho(1))
			else
				rho(1) = -rho(1)
			end if
		end if

		L = Blocks(2,1,start_index)/(Blocks(1,1,start_index)-rho(1))

		! Initial transform
		Blocks(2,:,start_index) = Blocks(2,:,start_index) - L*Blocks(1,:,start_index)

		! Turnover iterations
		do ii=(start_index+1),(stop_index)

			call ZGATO(Blocks(:,:,ii-1),Blocks(:,:,ii),L,flag)
			if(flag>0)then
				write(*,*) "Flag set at outer iteration ",mm," and inner iteration ",ii
				return
			end if

			! Dump the Bulge
			if(ii == stop_index)then

				Blocks(:,1,ii) = Blocks(:,1,ii) + L*Blocks(:,2,ii)

				exit
			end if

		end do

	end if

  end do

  ! set flag for maxing out loop
  if(mm == it_max)then
  	flag = 1
  end if

end subroutine

! **************************************************************
!
! This subroutine calculates the roots using any congenial matrix
!
! **************************************************************

subroutine ZBLR(N,K,POLY,COEFFS,ROOTS,ITERATIONS,FLAG)

	implicit none

	integer, intent(in) :: N,K
	complex(kind(1d0)), intent(in) :: POLY(N+1),COEFFS(N,K)
	complex(kind(1d0)), intent(inout) :: ROOTS(N)
	integer, intent(out) :: iterations(N),flag

	integer :: stop_index,start_index,zero_index,ii,jj,hh,mm,it_count=0,it_max
	integer :: length
	real(kind(1d0)) :: tolerance=1d-16,zero_point,diagonals,diag1,diag2
	complex(kind(1d0)) :: trace,detm,disc,DET,shift1,shift2,rho(1)
	complex(kind(1d0)) :: L,W(2,2),bulge
	complex(kind(1d0)), allocatable :: spike(:),Blocks(:,:,:),Bands(:,:)

! Initialize Bands and Blocks

	allocate(spike(N),Blocks(2,2,N),Bands(N,K))

	if(abs(poly(1)) == 0)then
		write(*,*) "Polynomial is of degree less than N!"
		flag = 1
		return
	end if

	spike = -Poly(2:(N+1))/Poly(1)*Coeffs(1,1)
	spike(1:(K-1)) = spike(1:(K-1)) + Coeffs(1,2:K)

	Bands = complex(0d0,0d0)
	Bands(1:(N-1),1:K) = Coeffs(2:N,1:K)

	Blocks(:,:,1) = complex(0d0,0d0)
	Blocks(2,2,1) = complex(1d0,0d0)

	do ii=1,(N-1)
		if(abs(Bands(ii,1)) == 0)then
			write(*,*) "Matrix is not properly upper-hessenberg!"
			flag = 2
			return
		end if

		L = spike(ii)/Bands(ii,1)

		length = min(N+1-ii,K)
		spike(ii:(ii+length-1)) = spike(ii:(ii+length-1)) - L*Bands(ii,1:length)

		Blocks(1,1,ii+1) = L
		Blocks(1,2,ii+1) = complex(1d0,0d0)
		Blocks(2,1,ii+1) = complex(1d0,0d0)
		Blocks(2,2,ii+1) = complex(0d0,0d0)
	end do

	Bands(N,1) = spike(N)

! Main loop

  stop_index = N
  start_index = 2
  zero_index = 1
  it_max = 20*N
  it_count = 0
  flag = 0

  do mm=1,it_max

	! Zero check
	do ii=1,stop_index
		zero_point = abs(Blocks(2,1,stop_index+1-ii))

		if(ii>1)then
			diag2 = abs(Blocks(1,1,stop_index+2-ii)*Blocks(2,2,stop_index+1-ii)*Bands(stop_index+1-ii,1))
		else
			diag2 = abs(Blocks(2,2,stop_index+1-ii)*Bands(stop_index+1-ii,1))
		end if

		if(ii<stop_index)then
			diag1 = abs(Blocks(1,1,stop_index+1-ii)*Blocks(2,2,stop_index-ii)*Bands(stop_index-ii,1))
		else
			diag1 = abs(Blocks(1,1,stop_index+1-ii)*Bands(stop_index-ii,1))
		end if

		diagonals = diag1 + diag2

		if(zero_point < tolerance*diagonals)then
			zero_index = stop_index+1-ii
			Blocks(2,1,zero_index) = complex(0d0,0d0)

			! Deflate down if not at bottom
			if(zero_index<stop_index)then
				Blocks(1,1,zero_index+1) = Blocks(1,1,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(1,2,zero_index+1) = Blocks(1,2,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(1,2,zero_index) = Blocks(1,2,zero_index)/Blocks(2,2,zero_index)
				Blocks(2,2,zero_index) = complex(1d0,0d0)
				start_index = zero_index+1
			end if

			exit

		end if
	end do

	! zero at bottom
	if(zero_index==stop_index)then
		ROOTS(zero_index) = Blocks(2,2,zero_index)*Bands(zero_index,1)

		iterations(N-zero_index+1) = it_count
		it_count = 0

		if(stop_index<=1)then
			exit
		end if

		! deflate up
		Blocks(:,2,zero_index-1) = Blocks(1,1,zero_index)*Blocks(:,2,zero_index-1)
		Blocks(1,1,zero_index) = complex(1d0,0d0)

		stop_index = stop_index-1

	! 2x2 case
	else if(stop_index==start_index)then

		! calculate eigenvalues using modified quadratic
		if(K == 1)then
		W(1,1) = Blocks(1,1,stop_index)*Bands(stop_index-1,1)
		W(1,2) = Blocks(1,2,stop_index)*Bands(stop_index,1)
		W(2,1) = Blocks(2,1,stop_index)*Bands(stop_index-1,1)
		W(2,2) = Blocks(2,2,stop_index)*Bands(stop_index,1)
		else
		W(1,1) = Blocks(1,1,stop_index)*Bands(stop_index-1,1)
		W(1,2) = Blocks(1,1,stop_index)*Bands(stop_index-1,2) + Blocks(1,2,stop_index)*Bands(stop_index,1)
		W(2,1) = Blocks(2,1,stop_index)*Bands(stop_index-1,1)
		W(2,2) = Blocks(2,1,stop_index)*Bands(stop_index-1,2) + Blocks(2,2,stop_index)*Bands(stop_index,1)
		end if

		trace = W(1,1) + W(2,2)
		detm = W(1,1)*W(2,2) - W(1,2)*W(2,1)

		disc = sqrt(trace*trace - 4*detm)

		if(abs(trace-disc)<abs(trace+disc))then
			if(abs(trace+disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace+disc)/2
				shift2 = 2*detm/(trace+disc)
			end if
		else
			if(abs(trace-disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace-disc)/2
				shift2 = 2*detm/(trace-disc)
			end if
		end if

		! store eigenvalues
		ROOTS(stop_index) = shift1
		ROOTS(stop_index-1) = shift2

		iterations(N-stop_index) = 0
		it_count = 0

		if(stop_index <= 2)then
			exit
		end if

		! deflate up
		Blocks(:,2,stop_index-2) = Blocks(1,1,stop_index-1)*Blocks(:,2,stop_index-2)
		Blocks(1,1,stop_index-1) = complex(1d0,0d0)

		stop_index = stop_index-2

	! more than one block
	else

		it_count = it_count + 1

		! shift calc
		if(K == 1)then
		W(1,1) = Blocks(1,1,stop_index)*Bands(stop_index-1,1)*Blocks(2,2,stop_index-1)
		W(1,2) = Blocks(1,2,stop_index)*Bands(stop_index,1)
		W(1,2) = W(1,2)*Blocks(2,2,stop_index-1)
		W(2,1) = Blocks(2,1,stop_index)*Bands(stop_index-1,1)
		W(2,2) = Blocks(2,2,stop_index)*Bands(stop_index,1)
		else
		W(1,1) = Blocks(1,1,stop_index)*Bands(stop_index-1,1)*Blocks(2,2,stop_index-1)
		W(1,2) = Blocks(1,1,stop_index)*Bands(stop_index-1,2) + Blocks(1,2,stop_index)*Bands(stop_index,1)
		W(1,2) = W(1,2)*Blocks(2,2,stop_index-1)
		W(2,1) = Blocks(2,1,stop_index)*Bands(stop_index-1,1)
		W(2,2) = Blocks(2,1,stop_index)*Bands(stop_index-1,2) + Blocks(2,2,stop_index)*Bands(stop_index,1)
		end if

		trace = W(1,1) + W(2,2)
		detm = W(1,1)*W(2,2) - W(1,2)*W(2,1)

		disc = sqrt(trace*trace - 4*detm)

		if(abs(trace-disc)<abs(trace+disc))then
			if(abs(trace+disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace+disc)/complex(2d0,0d0)
				shift2 = complex(2d0,0d0)*detm/(trace+disc)
			end if
		else
			if(abs(trace-disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace-disc)/complex(2d0,0d0)
				shift2 = complex(2d0,0d0)*detm/(trace-disc)
			end if
		end if

		if(mm == 0)then
			rho(1) = complex(dsqrt(2d0),dsqrt(2d0))
		else if(mod(it_count,15) == 0)then
			call cnormalpoly(1,rho(1))
			rho(1) = rho(1)
			write(*,*) "Exceptional shift in BLR!"
		else if(abs(Blocks(2,2,stop_index)*Bands(stop_index,1)-shift1)<abs(Blocks(2,2,stop_index)*Bands(stop_index,1)-shift2))then
			rho(1) = shift1
		else
			rho(1) = shift2
		end if

		! Build L
		if(abs(Blocks(1,1,start_index)*Bands(start_index-1,1)-rho(1)) == 0)then
			if(abs(rho(1)) == 0)then
				call cnormalpoly(1,rho(1))
				rho(1) = rho(1)/abs(rho(1))
			else
				rho(1) = -rho(1)
			end if
		end if

		L = Blocks(2,1,start_index)/(Blocks(1,1,start_index)*Bands(start_index-1,1)-rho(1))
		L = L*Bands(start_index-1,1)

		! Initial transform
		Blocks(2,:,start_index) = Blocks(2,:,start_index) - L*Blocks(1,:,start_index)

		! Turnover iterations
		do hh=(start_index),(stop_index-1)
			! Pass through Bands
			length = min(hh-start_index+1,K-1)
			do jj=1,length
				Bands(hh-jj,jj) = Bands(hh-jj,jj) + L*Bands(hh-jj,jj+1)
			end do

			bulge = L*Bands(hh,1)

			L = bulge/Bands(hh-1,1)

			length = min(K-1,stop_index+1-hh)
			do jj=1,length
				Bands(hh,jj) = Bands(hh,jj) - L*Bands(hh-1,jj+1)
			end do

			! Pass through Blocks
			call ZGATO(Blocks(:,:,hh),Blocks(:,:,hh+1),L,flag)
			if(flag>0)then
				write(*,*) "Flag set at outer iteration ",mm," and inner iteration ",hh
				return
			end if
		end do

		! Dump the Bulge
			! Pass through Bands
			length = min(stop_index-start_index+1,K-1)
			do jj=1,length
				Bands(stop_index-jj,jj) = Bands(stop_index-jj,jj) + L*Bands(stop_index-jj,jj+1)
			end do

			bulge = L*Bands(stop_index,1)

			L = bulge/Bands(stop_index-1,1)

			if(K == 1)then
				Bands(stop_index,1) = Bands(stop_index,1)
			else
				Bands(stop_index,1) = Bands(stop_index,1) - L*Bands(stop_index-1,2)
			end if

		Blocks(:,1,stop_index) = Blocks(:,1,stop_index) + L*Blocks(:,2,stop_index)

	end if

  end do

  ! set flag for maxing out loop
  if(mm == it_max)then
  	flag = 1
  end if

	! free memory
	deallocate(spike,Blocks,Bands)

end subroutine

! ****************************************************************************
!
! This subroutine passes a Gauss transform through two adjacent core
! transformations.
!
! ****************************************************************************

subroutine ZGATO(A,B,L,flag)

	implicit none

	integer, intent(inout) :: flag
	complex(kind(1d0)), intent(inout) :: A(2,2),B(2,2),L

	! Update A
	A(:,1) = A(:,1) + L*B(1,1)*A(:,2)

	! pivot decision
	if(abs(A(2,1)) == 0)then
		flag = 1
		return
	end if

	L = L*B(2,1)/A(2,1)

	! Update B
	B(2,:) = B(2,:) - L*A(2,2)*B(1,:)

end subroutine

! ****************************************************************************
!
! This subroutine generates a one dimensional complex array whose entries are
! normally distributed with mean 0 and variance 1 in both the real and imaginary parts
!
! ****************************************************************************

subroutine cnormalpoly(degree,poly)

	implicit none

	integer, intent(in) :: degree
	complex(kind(1d0)), intent(inout) :: poly(degree)

	double precision :: u,v,s,pi = 3.141592653589793239d0
	integer :: i,j

	do i=1,degree
		do j=1,20

			call random_number(u)
			call random_number(v)

			s = u**2 + v**2

			if(s > 0 .and. s < 1)then
				poly(i) = complex(cos(2.d0*pi*v)*dsqrt(-2.d0*log(u)),sin(2.d0*pi*v)*dsqrt(-2.d0*log(u)))
				exit
			end if
		end do

	end do

end subroutine

! ****************************************************************************
!
! This subroutine initializes the random seed using the cpu time
!
! ****************************************************************************

SUBROUTINE init_random_seed()

	implicit none

        INTEGER :: i, n, clock
        INTEGER, DIMENSION(:), ALLOCATABLE :: seed

        CALL RANDOM_SEED(size = n)
        ALLOCATE(seed(n))

        CALL SYSTEM_CLOCK(COUNT=clock)

        seed = clock + 37 * (/ (i - 1, i = 1, n) /)
        CALL RANDOM_SEED(PUT = seed)

	DEALLOCATE(seed)

END SUBROUTINE


module math
implicit none

private
public :: dummy_math
public :: norm_sq, norm, dot, cross, binomial

contains

subroutine dummy_math()
    !> Dummy routine for f2py.
end subroutine dummy_math

function norm_sq(v) result(vn_sq)
    !> Squared vector norm.
    !> v - Vector.
    !> vn_sq - Squared vector norm.

    ! Input
    double precision, intent(in) :: v(:)

    ! Output
    double precision :: vn_sq

    ! Working
    integer :: n, i

    vn_sq = 0.0d0
    n = size(v, 1)
    do i = 1, n
        vn_sq = vn_sq + v(i) * v(i)
    end do

end function norm_sq

function norm(v) result(vn)
    !> Vector norm.
    !> v - Vector.
    !> vn - Vector norm.

    ! Input
    double precision, intent(in) :: v(:)

    ! Output
    double precision :: vn

    ! Working
    double precision :: vn_sq

    vn_sq = norm_sq(v)
    vn = dsqrt(vn_sq)

end function norm

function dot(v1, v2) result(dp)
    !> Dot product of two vector.
    !> v1 - Vector 1.
    !> v2 - Vector 2.

    ! Input
    double precision, intent(in) :: v1(:), v2(:)

    ! Output
    double precision :: dp

    ! Working
    integer :: n1, n2, i

    dp = 0.0d0
    n1 = size(v1, 1)
    n2 = size(v2, 1)
    do i = 1, min(n1, n2)
        dp = dp + v1(i) * v2(i)
    end do

end function dot

function cross(v1, v2) result(vc)
    !> Cross product of two vectors.
    !> v1 - Vector 1.
    !> v2 - Vector 2.
    !> vcross - Vector cross product.

    ! Input
    double precision, intent(in) :: v1(3), v2(3)

    ! Output
    double precision :: vc(3)

    vc(1) = v1(2) * v2(3) - v1(3) * v2(2)
    vc(2) = -(v1(1) * v2(3) - v1(3) * v2(1))
    vc(3) = v1(1) * v2(2) - v1(2) * v2(1)
end function cross

function binomial(n, k) result(bc)
    !> Compute binomial coefficients.
    !> n - Non-negative integer (n > 0).
    !> k - Non-negative integer (k < n).
    !> bc - Binomial coefficient.

    ! Input
    integer, intent(in) :: n, k

    ! Output
    double precision :: bc

    ! Working
    integer :: i, kk

    if ((k .lt. 0) .or. ( k .gt. n)) then
        bc = 0.0d0
        return
    end if
    if ((k .eq. 0) .or. ( k .eq. n)) then
        bc = 1.0d0
        return
    end if
    kk = min(k, n - k)
    bc = 1.0d0
    do i = 0, kk - 1
        bc = bc * dble(n - i) / dble(i + 1)
    end do

end function binomial

end module math


***********************************************************************
c                    ORBEL_ZGET.F
***********************************************************************
*     PURPOSE:  Solves the equivalent of Kepler's eqn. for a parabola
*          given Q (Fitz. notation.)
*
*             Input:
*                           q ==>  parabola mean anomaly. (real scalar)
*             Returns:
*                  orbel_zget ==>  eccentric anomaly. (real scalar)
*
*     ALGORITHM: p. 70-72 of Fitzpatrick's book "Princ. of Cel. Mech."
*     REMARKS: For a parabola we can solve analytically.
*     AUTHOR: M. Duncan
*     DATE WRITTEN: May 11, 1992.
*     REVISIONS: May 27 - corrected it for negative Q and use power
*	      series for small Q.
***********************************************************************

	real*8 function orbel_zget(q)

      include '../swift.inc'

c...  Inputs Only:
	real*8 q

c...  Internals:
	integer iflag
	real*8 x,tmp

c----
c...  Executable code

	iflag = 0
	if(q.lt.0.d0) then
	  iflag = 1
	  q = -q
	endif

	if (q.lt.1.d-3) then
	   orbel_zget = q*(1.d0 - (q*q/3.d0)*(1.d0 -q*q))
	else
	   x = 0.5d0*(3.d0*q + sqrt(9.d0*(q**2) +4.d0))
	   tmp = x**(1.d0/3.d0)
	   orbel_zget = tmp - 1.d0/tmp
	endif

	if(iflag .eq.1) then
           orbel_zget = -orbel_zget
	   q = -q
	endif

	return
	end    ! orbel_zget
c----------------------------------------------------------------------


        SUBROUTINE LNSGIN ( xlin, ylin, xlins, ylins, npts, mxint,
     +                      numint, xint, yint, iret )
C************************************************************************
C* LNSGIN                                                               *
C*                                                                      *
C* This subroutine calculates and returns all the intersection points	*
C* of a straight line, (XLIN(1),YLIN(1))-(XLIN(2),YLIN(2)), with a	*
C* 'curved' line, (XLINS(1),YLINS(1)) - (XLINS(2),YLINS(2)) - ... -	*
C* (XLINS(NPTS),YLINS(NPTS)) consisting of NPTS points.			*
C*                                                                      *
C* LNSGIN ( XLIN, YLIN, XLINS, YLINS, NPTS, MAXINT, 			*
C*	    NUMINT, XINT, YINT, IRET )					*
C*                                                                      *
C* Input parameters:                                                    *
C*      XLIN (2)        REAL            Straight line X input coords	*
C*      YLIN (2)        REAL            Straight line Y input coords	*
C*      XLINS (NPTS)    REAL            Curved line X input coords	*
C*      YLINS (NPTS)    REAL            Curved line Y input coords	*
C*	NPTS		INTEGER		Number of points along X/YLINS	*
C*	MXINT		INTEGER		Max number of intersections	*
C*                                                                      *
C* Output parameters:                                                   *
C*	NUMINT		INTEGER		Number of intersections		*
C*      XINT (NUMINT)   REAL            X intersection coordinates      *
C*      YINT (NUMINT)   REAL            Y intersection coordinates      *
C*      IRET            INTEGER         Return code                     *
C*					= 3 - mxint exceeded		*
C**                                                                     *
C* Log:                                                                 *
C* D.W.Plummer/NCEP	 9/98						*
C* D.W.Plummer/NCEP	 9/01	Implement check for maxint		*
C* D.W.Plummer/NCEP	 7/03	Chg variable maxint to mxint		*
C* D.W.Plummer/NCEP	 8/05	Rm rounding of ints to nearest 100th 	*
C************************************************************************
C
	REAL		xlin(*), ylin(*), xlins(*), ylins(*)
	REAL		xint(*), yint(*)
C
	REAL*8		m, ms, b, bn, bn1, bs
C
	iret = 0
	numint = 0
C
C*	Check for vertical line and get intersects for crossing segments.
C
	IF ( xlin(1) .eq. xlin(2) )  THEN
C
	    DO  n = 1, npts-1
C
		IF ( xlins(n  ) .eq. xlin(1) .and.
     +		     xlins(n+1) .eq. xlin(1) )  THEN
C
		    IF ( numint+1 .le. mxint )  THEN
C
		      numint = numint + 1
		      xint(numint) = xlin(1)
		      yint(numint) = ( ylins(n) + ylins(n+1) ) / 2.0
C
		    ELSE
C
		      iret = 3
		      RETURN
C
		    END IF
C
		ELSE IF ( ( xlins(n  ) .le. xlin(1) .and.
     +			    xlins(n+1) .ge. xlin(1) )  .or.
     +			  ( xlins(n  ) .ge. xlin(1) .and.
     +                      xlins(n+1) .le. xlin(1) ) )  THEN
C
		    IF ( numint+1 .le. mxint )  THEN
C
		      numint = numint + 1
		      xint(numint) = NINT( xlin(1) * 100.0 ) / 100.0
		      m = (ylins(n+1)-ylins(n)) / (xlins(n+1)-xlins(n))
		      b = ylins(n) - m * xlins(n)
		      yint(numint) = m * xint(numint) + b
		      yint(numint) = NINT( yint(numint) * 100.0 ) / 100.0
C
		    ELSE
C
		      iret = 3
		      RETURN
C
		    END IF
C
		END IF
C
	    END DO
C
	ELSE
C
	    m = ( ylin(2)-ylin(1) ) / ( xlin(2)-xlin(1) )
	    b = ylin(1) - m * xlin(1)
C
	    DO  n = 1, npts-1
C
		bn  = ylins(n  ) - m * xlins(n  )
		bn1 = ylins(n+1) - m * xlins(n+1)
C
		IF ( bn .eq. b .and. bn1 .eq. b )  THEN
C
		    IF ( numint+1 .le. mxint )  THEN
C
		      numint = numint + 1
		      xint(numint) = ( xlins(n) + xlins(n+1) ) / 2.0
		      yint(numint) = ( ylins(n) + ylins(n+1) ) / 2.0
C
		    ELSE
C
		      iret = 3
		      RETURN
C
		    END IF
C
		ELSE IF ( ( bn .ge. b .and. bn1 .le. b ) .or.
     +			  ( bn .le. b .and. bn1 .ge. b ) )  THEN
C
		    IF ( numint+1 .le. mxint )  THEN
C
		      numint = numint + 1
C
		      IF ( xlins(n+1) .ne. xlins(n) )  THEN
C
			ms = (ylins(n+1)-ylins(n))/(xlins(n+1)-xlins(n))
			bs = ylins(n) - ms * xlins(n)
			xint(numint) = ( bs - b ) / ( m - ms )
C
		      ELSE
C
			xint(numint) = xlins(n)
C
		      END IF
C
		      yint(numint) = m * xint(numint) + b
C
		    ELSE
C
		      iret = 3
		      RETURN
C
		    END IF
C
		END IF
C
	    END DO
C
 	END IF
C
	RETURN
	END


module HyPerLayer
implicit none

real, parameter :: FP_INT_CORR = 0.5

contains

!$FTT vectorize
elemental real function xPos(idx, nx, x0, dx, numFeatures) result(x)
    integer, intent(in) :: idx, nx, numFeatures
    real,    intent(in) :: dx, x0

    x = x0 + dx*(0.5 + mod(idx/numFeatures, nx))

end function xPos

!$FTT vectorize
elemental real function yPos(idx, nx, y0, dy, numFeatures) result(y)
    integer, intent(in) :: idx, nx, numFeatures
    real,    intent(in) :: dy, y0

    y = y0 + dy*(0.5 + (idx/(nx*numFeatures)))

end function yPos

!$FTT vectorize
elemental integer function featureIndex(idx, numFeatures) result(kf)
    integer, intent(in) :: idx, numFeatures

    kf = mod(idx, numFeatures)

end function featureIndex

!$FTT vectorize
elemental integer function index(kf, x, y, x0, y0, dx, dy, nx, numFeatures) result(idx)
    real, intent(in)    :: x, y, x0, y0, dx, dy
    integer, intent(in) :: kf, nx, numFeatures
    integer :: kx, ky

    kx = INT( (x - x0)/dx - 0.5 + FP_INT_CORR )
    ky = INT( (y - y0)/dy - 0.5 + FP_INT_CORR )
    idx = (kx + nx*ky)*numFeatures + kf

end function index

end module HyperLayer


! test_newuoa.f90 --
!
!     The Chebyquad test problem (Fletcher, 1965) for N = 2,4,6 and 8,
!     with NPT = 2N+1.
!
module newuoa_functions
    use newuoa_minimisation, only: wp

    implicit none

contains

subroutine calfun( x, f )
    real(kind=wp), dimension(:) :: x
    real(kind=wp)               :: f

    real(kind=wp), dimension(:) :: y(10,10)
    real(kind=wp)               :: sum
    integer                     :: i, j, n, np, iw

    n = size(x)
    do j = 1,n
        y(1,j) = 1.0d0
        y(2,j) = 2.0d0 * x(j) - 1.0d0
    enddo

    do i = 2,n
        do j = 1,n
            y(i+1,j) = 2.0d0 * y(2,j) * y(i,j) - y(i-1,j)
        enddo
    enddo

    f  = 0.0d0
    np = n + 1
    iw = 1

    do i = 1,np
        sum = 0.0d0
        do j = 1,n
            sum = sum + y(i,j)
        enddo
        sum = sum / real(n,wp)
        if ( iw > 0) sum = sum + 1.0d0 / real(i*i-2*i,wp)
        iw = -iw
        f  =  f + sum * sum
    enddo
end subroutine calfun

end module newuoa_functions

program test_newuoa
    use newuoa_minimisation
    use newuoa_functions

    real(kind=wp), dimension(10) :: x
    real(kind=wp)                :: rhobeg, rhoend
    integer                      :: iprint, maxfun
    integer                      :: i, n, npt

    iprint = 2
    maxfun = 5000
    rhoend = 1.0d-6

    do n = 2,8,2
        npt = 2 * n + 1
        do i = 1,n
            x(i) = real(i,wp)/real(n+1,wp)
        enddo

        rhobeg = 0.2d0 * x(1)
        print 20, n,npt
 20     format (//4x,'results with n =',i2,' and npt =',i3)

        call newuoa( npt, x(1:n), rhobeg, rhoend, iprint, maxfun, calfun )

    enddo
end program test_newuoa


program list05p
! CAP372 - exercise 5 - 2019-09-15 - Parallel version
! Based on "Introduction to Parallel Programming: Matrix Multiplication"
! by  Gergel V.P. :
! <http://www.lac.inpe.br/~stephan/CAP-372/matrixmult_microsoft.pdf>
! - Each subtask i hold one row of matrix A and one column of matrix B .
! - The result is stored in one element of C .
! - After that, every subtask i, 0≤i<n, transmits its column of matrix B
!   to the subtask with the number (i + 1) mod n .
! - When the number of processors ("p") is less than the number of
!   basic subtasks ("n"), each processor would execute several
!   inner products of matrix A rows and matrix B columns.
! - Each aggregated basic subtask ( = the calculation of one row of C)
!   determines several rows of the result matrix C.
! module load intel_psxe/2019
! mpiifort -g -check all -fpe0 -warn -traceback -debug extended  &
!           -o ilist05p ilist05p.f90
! mpirun -n 2 ./ilist05p
! or if using gnu: mpif90 -Og -fcheck=all list05p.f90

  use MPI
  implicit none

  integer, parameter :: ms=512                        ! matrix size ms x ms
  integer, parameter :: ps=2                          ! expected processes
  integer, parameter :: st=ms/ps                      ! # of stripes
  double precision, dimension(ms, ms) :: A, B, C=0    ! matrix definition
  double precision, dimension(st, ms) :: AR=0         ! stripes: A Rows
  double precision, dimension(ms, st) :: BC=0         ! stripes: B Cols
  double precision, dimension(st, st) :: CS=0         ! stripes: C Stripe
  double precision, dimension(ms)     :: AT=0, BT=0   ! temporary
  integer :: stripe_i, stripe_countA, stripe_countB   ! counters
  integer :: mi, mj, mk, source, dest, i              ! indexes
  integer :: interation, subtask                      ! looping
  double precision :: t1, t2, ttot, tcal=0, tcom=0    ! time elapsed
  double precision :: temp1                           ! temporary value

  ! MPI Initialization
  integer :: my_rank, sender, p, ierr                 ! mpi variables
  integer :: tagC=0                                   ! variable tag
  integer, parameter ::  &
    tag=0,  &                         ! general use tag
    tagB=99999,  &                    ! tag for B matrix send
    tagTcom=99998,  &                 ! tag for communication time elapsed
    tagTcal=99997                     ! tag for calculation time elapsed
  integer, dimension(MPI_STATUS_SIZE) :: status       ! mpi status
  call MPI_Init(ierr)                                 ! mpi initialize
  call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierr)   ! mpi processor's id
  call MPI_Comm_size(MPI_COMM_WORLD, p, ierr)         ! mpi # of processors
  if (p .ne. ps) then                                 ! abort if ps <> p
    if (my_rank .eq. 0) then
      print*, "Error: # of mpi processes is", p, " and the expected is", ps
    endif
    stop
  end if
  if (my_rank .eq. 0) then
    ttot = MPI_Wtime()                ! Elapsed time calculation.
    ! *** Each subtask hold one row|colomn of matrix A|B and return C ***
    ! The rank 0 has the entire matrix A|B .
    A = reshape([(mi, mi=1, ms*ms)], shape(A))
    B = reshape([(mi, mi=ms*ms+1, ms*ms*2)], shape(B))
  end if

  !########## BEGIN SEND DATA TO THE FIRST INTERATION #########################
  ! Each subtask is one processor.
  ! Row A # is the same for the same subtask #, and then it is only
  ! necessary send|recv one time.
  if (my_rank .eq. 0) then            ! Rank 0 has the entire matrix.
    t1 = MPI_Wtime()                  ! Start elapsed time calculation.
    do dest = 1, ms / st -1           ! Send to the subtask.
      do stripe_countA = 1, st        ! Send the stripe.
        mi = dest * st + stripe_countA  ! calculate stripe line
        ! Send row by row. Can be optimized to send a block.
        AT = A(mi, :)
        call MPI_Send(AT, ms, MPI_DOUBLE_PRECISION,   &
                      dest, tag, MPI_COMM_WORLD, ierr)
      end do  ! stripe_countA
    end do  ! dest
    do mi = 1, st                     ! Rank 0: copy A stripe to AR
        AR(mi, :) = A(mi, :)
    end do ! mi
  end if
  ! And then each subtask i, 0<i<n,receives. The i=0 is not necessary.
  if (my_rank .ne. 0) then            ! Rank > 0 receive the stripe.
    do stripe_countA = 1, st          ! Recv the A stripe.
      ! For sure it can be optimized, instead of receiving line by line.
      call MPI_Recv(AT, ms, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE,   &
                    MPI_ANY_TAG, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
      AR(stripe_countA, :) = AT
    end do  ! stripe_countA
    t2 = MPI_Wtime() - t1       ! Elapsed time to send initial data
    tcom = tcom + t2
  end if  ! my_rank .ne. 0

  ! In the first interaction, the subtasks should receive initial B row.
  ! In the next interations, each substask send to another.
  ! First time B row send:
  if (my_rank .eq. 0) then            ! Rank 0 has the entire matrix.
    interation = 0                    ! Interation of the algorithm.
    do subtask = 0, ms / st - 1       ! Each subtask hold one matrix row.
      do stripe_countB = 0,  st - 1   ! Count for p < n .
        ! stripe column calculation
        stripe_i = st * mod(subtask + p - interation, p) + stripe_countB
        mk = stripe_i + 1             ! Matrix B column index
        if (subtask .eq. 0) then
          BC(:, mk) = B(:, mk)        ! Rank 0 only copy
        else
          BT = B(:, mk)               ! Send to rank > 0
          dest = subtask
          call MPI_Send(BT, ms, MPI_DOUBLE_PRECISION,   &
                        dest, tag, MPI_COMM_WORLD, ierr)
        endif  ! subtask
      end do  ! stripe_countB
    end do  ! subtask
  end if  ! my_rank

  ! Recv B row that was sent
  if (my_rank .ne. 0) then
    do stripe_countB = 0,  st - 1       ! Count for p < n
      call MPI_Recv(BT, ms, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE,   &
          MPI_ANY_TAG, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
      BC(:, stripe_countB + 1) = BT
    end do  ! stripe_countB
  end if  ! my_rank

  !++++++++++ START INTERATION ALGORITHM ++++++++++++++++++++++++++++++++++++++
  do interation = 0, ms / st - 1      ! Algorithm interation.
    t1 = MPI_Wtime()                  ! Start elapsed time calculation.
    ! Every subtask receives its row|col of matrix A|B
    subtask = my_rank                 ! Each subtask hold one matrix A|B row|col
    ! >>>>>>>>>> START STRIPE <<<<<<<<<<
    do stripe_countA = 0, st - 1      ! A count for p < n
      do stripe_countB = 0,  st - 1   ! count for p < n
        ! stripe column calculation
        stripe_i = st * mod(subtask+p-interation,p) + stripe_countB
        ! matrix A line calculation
        mi = st * subtask + stripe_countA + 1
        temp1 = 0                     ! multiplication: A line x B column
        do mj = 1, ms                 ! count A column
          mk = stripe_i + 1           ! B column index
          ! C = A x B. Can be optimized using intrinsic functions
          temp1 = temp1 + AR(stripe_countA+1, mj) * BC(mj, stripe_countB+1)
        end do
        CS(stripe_countA+1, stripe_countB+1) = temp1  ! store C element
      end do
    end do   ! >>>>>>>>>> END STRIPE <<<<<<<<<<
    ! Each rank has their partial time and must send to the rank 0
    t2 = MPI_Wtime() - t1
    if (my_rank .ne. 0) then          ! rank 0 accumulate
      call MPI_Send(t2, 1, MPI_DOUBLE_PRECISION, 0,  &
                    tagTcal, MPI_COMM_WORLD, ierr)
    else
      tcal = tcal + t2             ! rank 0 own time
      call MPI_Recv(t2, 1, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE,  &
                    tagTcal, MPI_COMM_WORLD, status, ierr)
      tcal = tcal + t2             ! other rank time
    endif  ! End calculation elapsed time calculation

    ! $$$$$$$$$$ send C stripe to rank 0 $$$$$$$$$$
    ! Each subtask should return the calculated C to rank 0
    t1 = MPI_Wtime()                  ! Start elapsed time calculation.
    if (my_rank .ne. 0) then          ! Rank 0 does not need to send
      tagC = interation
      do mj = 1,  st                    ! Send one stripe.
        call MPI_Send(CS(:,mj), st, MPI_DOUBLE_PRECISION, 0, tagC, &
                      MPI_COMM_WORLD, ierr)
      end do
    end if
    ! Rank 0 is responsible for completing the matrix C
    if (my_rank .eq. 0) then
      ! For sure there is a whay to optimize this part of code
      ! SEND C stripe
      do stripe_countA = 0, st - 1
        do stripe_countB = 0, st - 1
          stripe_i = st * mod(0 + p - interation, p) + stripe_countB + 1
          mi = stripe_countA + 1
          C(mi, stripe_i) = CS(stripe_countA + 1, stripe_countB + 1)
        end do
      end do
      ! RECV C stripe
      do source = 1,  ps - 1          ! recv from ranks > 0 and store in C
        ! Receive the corresponding C
        do mj = 1,  st                ! Recv one stripe.
          call MPI_Recv(CS(:, mj), st * st, MPI_DOUBLE_PRECISION, source, &
                        MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
        end do
        sender  = status(MPI_SOURCE)
        i       = status(MPI_TAG)
        ! For sure there is a whay to optimize this part of code
        do stripe_countA = 0, st - 1
          do stripe_countB = 0,  st - 1
            mi = st * sender + stripe_countA + 1      ! Calculate C line index
            stripe_i = st * mod(sender + p - i, p) + stripe_countB
            mk = stripe_i + 1         ! B column index
            C(mi , mk) = CS(stripe_countA + 1, stripe_countB + 1)
          end do  ! stripe_countA
        end do  ! stripe_countB
      end do  ! source
    end if  ! $$$$$$$$$$ END OF SEND C $$$$$$$$$$

    ! @@@@@@@@@@ send and recv B @@@@@@@@@@
    ! At the end of one interation, every subtask transmits its column
    ! of matrix B to the subtask with the number (i + 1) mod n .
    ! NOTE: the count index in Intel MPI implementation is a 4-byte integer,
    ! so the maximum allowed value is 2^31-1 : 2.147.483.647 .
    ! I had a lot o trouble with this...........
    if (interation .lt. (ms / st - 1)) then   ! Not need in the last interation.
      dest = mod(my_rank + 1, ps)
      do mj = 1,  st                  ! Send one stripe.
        ! tagAB ensures no confusion with matrix C
        call MPI_Send(BC(:,mj), ms, MPI_DOUBLE_PRECISION, dest,  &
                      tagB, MPI_COMM_WORLD, ierr)
      end do
      ! Each subtask recv
      do mj = 1,  st                  ! Recv one stripe.
        ! tagAB ensures no confusion with matrix C
        call MPI_Recv(BC(:,mj), ms, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE,  &
                      tagB, MPI_COMM_WORLD, status, ierr)
      end do
    end if

    ! Each rank has their partial time and must send to the rank 0
    t2 = MPI_Wtime() - t1
    if (my_rank .ne. 0) then          ! rank 0 accumulate
      call MPI_Send(t2, 1, MPI_DOUBLE_PRECISION, 0,  &
                    tagTcom, MPI_COMM_WORLD, ierr)
    else
      tcom = tcom + t2             ! rank 0 own time
      call MPI_Recv(t2, 1, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE,  &
                    tagTcom, MPI_COMM_WORLD, status, ierr)
      tcom = tcom + t2             ! other rank time
    endif  ! End communication elapsed time calculation

  end do  ! ++++++++++ END INTERATION ++++++++++

  !%%%%%%%%%% SHOW THE RESULT %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  if (my_rank .eq. 0) then
    ttot = MPI_Wtime() - ttot         ! Elapsed time calculation.
    write(*, '(a, i5, 3x, a, i2, 3x, a, f7.4, 3x, a, f7.4, 3x, a, f7.4)')   &
      'Matrix size:', ms,  &
      'Processors:', p,  &
      'Total time:', ttot,  &
      'Comm time:', tcom, &
      'Calc time:', tcal
  end if

  call MPI_Finalize(ierr)             ! mpi finalize
end program list05p


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Makes Butcher array for Runge-Kutta scheme
!! @author Ilario Mazzieri
!> @note Compute low storage Butcher array for Runge-Kutta(p,s) time integration scheme
!  where p is the order of the scheme and s is the number of stages
!  Schemes Implemented: RK(2,2), RK(3,3), RK(4,4)
!> @date September, 2013
!> @version 1.0
!> @param[in] order  p
!> @param[in] stages  s
!> @param[out] A_low  low storage Butcher array A
!> @param[out] B_low  low storage Butcher array B
!> @param[out] c  Butcher array c

     subroutine MAKE_BUTCHERARRAY(order, stages, A_low, B_low, c)

     implicit none

     integer*4:: order, stages
     real*8, dimension(stages,stages) :: A
     real*8, dimension(stages) :: b, c, A_low, B_low

     A = 0; b = 0; c = 0; A_low = 0; B_low = 0;

     select case(order)

        case(2)
           ! RK(2,2)
           select case(stages)
              case(2)
                 c(2) = 1
                 b(1) = 0.5; b(2)=0.5
                 A(2,1) = 1

                 call MAKE_LOW_STORAGE_COEFFICIENTS(stages,A,b,c,A_low,B_low)

              case default
                  write(*,'(A)') 'RK scheme not implemented'
           end select

        case(3)
           ! RK(3,3)
           select case(stages)
              case(3)
                 c(2) = 0.5; c(3) = 1
                 b(1) = 1.d0/6; b(2) = 2.d0/3; b(3) = 1.d0/6
                 A(2,1) = 0.5;
                 A(3,1) = -1; A(3,2) = 2

                 call MAKE_LOW_STORAGE_COEFFICIENTS(stages,A,b,c,A_low,B_low)

              case default
                  write(*,'(A)') 'RK scheme not implemented'
           end select

        case(4)

           select case(stages)
              ! RK(4,4)
              case(4)
                 c(2) = 0.5; c(3) = 0.5; c(4) = 1
                 b(1) = 1.d0/6; b(2) = 1.d0/3; b(3) = 1.d0/3; b(4) = 1.d0/6
                 A(2,1) = 0.5;
                 A(3,2) = 0.5;
                 A(4,3) = 1;

                 call MAKE_LOW_STORAGE_COEFFICIENTS(stages,A,b,c,A_low,B_low)

              case default
                  write(*,'(A)') 'RK scheme not implemented'

           end select

        case default
           write(*,'(A)') 'RK scheme not implemented'

      end select

     end subroutine MAKE_BUTCHERARRAY

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

!> @brief Computes Low-storage memory coefficients for Runge-Kutta scheme
!! @author Ilario Mazzieri
!> @note Compute low storage Butcher array for Runge-Kutta(p,s) time integration scheme
!!  where p is the order of the scheme and s is the number of stages
!> @date September, 2013
!> @version 1.0
!> @param[in] stages  s
!> @param[in] A Butcher array
!> @param[in] b Butcher array
!> @param[in] c Butcher array
!> @param[out] A_low  low storage Butcher array A
!> @param[out] B_low  low storage Butcher array B

     subroutine MAKE_LOW_STORAGE_COEFFICIENTS(stages,A,b,c,A_low,B_low)

     implicit none

     integer*4:: stages
     real*8, dimension(stages,stages) :: A
     real*8, dimension(stages) :: b, c, A_low, B_low
     integer*4 :: i

     ! Compute Low storage coefficients according to the
     ! paper Toulorge and Desmet: "Optimal Runge-Kutta schemes for discontinuous
     ! Galerkin space discretizations applied to wave propagation problems"

     A_low(1) = 0;

     do i = 1, stages -1
        B_low(i) = a(i+1,i)
     enddo
     B_low(stages) = b(stages)

     do i = 2, stages
        if (b(i) .ne. 0.d0) then
           A_low(i) = (b(i-1) - B_low(i-1))/b(i);
        else
           A_low(i) = (A(i+1,i-1) - c(i))/B_low(i);
        endif
     enddo

     end subroutine MAKE_LOW_STORAGE_COEFFICIENTS


program fibo
  use iso_fortran_env, only : real64
  implicit none

  integer, parameter :: fib = 45

  write(*,*) fibonacci(fib)

contains

  function fibonacci(n) result(res)
    integer, intent(in) :: n
    integer :: res

    res = fibo_naive(n)
    !res = fibo_tail(0,1,n)

  end function fibonacci

  recursive function fibo_naive(n) result(res)
    integer, intent(in) :: n
    integer :: res

    if(n <= 0) then
       res = 0
       return
    end if

    if(n == 1) then
       res = 1
       return
    end if

    res = fibo_naive(n-1) + fibo_naive(n-2)

  end function fibo_naive

  recursive function fibo_tail(prev2,prev1,n) result(res)
    integer,intent(in) :: prev2,prev1,n
    integer :: res

    if(n == 0) then
       res = prev2
       return
    end if

    res = fibo_tail(prev1,prev1+prev2,n-1)

  end function fibo_tail

end program fibo


! Solve Poisson equation
!  u_{xx} = f(x)    x \in [a, b]
! with
!  u(a) = alpha, u(b) = beta
! using Jacobi iteration using MPI.
program jacobi_mpi

    use mpi

    implicit none

    real (kind=8), parameter :: alpha = 0.d0, beta = 3.d0

    integer :: i, start, end, points_per_task, task_id, N
    integer :: error, num_tasks, my_id, req1, req2
    integer, dimension(MPI_STATUS_SIZE) :: mpi_status
    real(kind=8), dimension(:), allocatable :: f, u, u_old
    real(kind=8) :: x, du_max_task, du_max_global, dx, tolerance

    integer(kind=8) :: num_iterations
    integer(kind=8), parameter :: MAX_ITERATIONS = 2**32_8
    integer, parameter :: PRINT_INTERVAL = 5000

    ! Initialize MPI; get total number of tasks and ID of this task
    call mpi_init(error)
    call mpi_comm_size(MPI_COMM_WORLD, num_tasks, error)
    call mpi_comm_rank(MPI_COMM_WORLD, my_id, error)

    ! Ask the user for the number of points
    ! if (me == 0) then
    !     print *, "Input n ... "
    !     read *, n
    ! end if
    N = 100
    ! Broadcast to all tasks; everybody gets the value of n from task 0
    call mpi_bcast(N, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, error)

    dx = 1.d0 / real(N + 1, kind=8)
    tolerance = 0.1d0*dx**2

    ! Determine how many points to handle with each task
    points_per_task = (N + num_tasks - 1) / num_tasks
    if (my_id == 0) then   ! Only one task should print to avoid clutter
        print *, "points_per_task = ", points_per_task
    end if

    ! Determine start and end index for this task's points
    start = my_id * points_per_task + 1
    end = min((my_id + 1) * points_per_task, n)

    ! Diagnostic: tell the user which points will be handled by which task
    print '("Task ",i2," will take i = ",i6," through i = ",i6)', &
        my_id, start, end

    ! Initialize:
    ! -----------

    ! This makes the indices run from istart-1 to end+1
    ! This is more or less cosmetic, but makes things easier to think about
    allocate(f(start - 1:end + 1))
    allocate(u(start - 1:end + 1))
    allocate(u_old(start - 1:end + 1))

    ! Each task sets its own, independent array
    do i = start, end
        ! Each task is a single thread with all its variables private
        ! so re-using the scalar variable x from one loop iteration to
        ! the next does not produce a race condition.
        x = dx * real(i, kind=8)
        f(i) = exp(x)                        ! RHS
        u(i) = alpha + x * (beta - alpha)    ! Initial guess
    end do

    ! Set boundary conditions if this task is keeping track of a boundary
    ! point
    if (my_id == 0) then
        u(start - 1) = alpha
    end if
    if (my_id == num_tasks - 1) then
        u(end + 1) = beta
    end if

    ! Jacobi iteratation:
    ! -------------------

    do num_iterations = 1, MAX_ITERATIONS
        u_old = u

        ! Send endpoint values to tasks handling neighboring sections
        ! of the array.  Note that non-blocking sends are used; note
        ! also that this sends from u_old, so the buffer we're sending
        ! from won't be modified while it's being sent.
        !
        ! tag = 1 is used for messages sent to the left
        ! tag = 2 is used for messages sent to the right

        if (my_id > 0) then
            ! Send left endpoint value to process to the "left"
            ! Note that this is a "non-blocking send"
            call mpi_isend(u_old(start), 1, MPI_DOUBLE_PRECISION, my_id - 1, &
                1, MPI_COMM_WORLD, req1, error)
        end if
        if (my_id < num_tasks - 1) then
            ! Send right endpoint value to process on the "right"
            ! Note that this is a "non-blocking send"
            call mpi_isend(u_old(end), 1, MPI_DOUBLE_PRECISION, my_id + 1, &
                2, MPI_COMM_WORLD, req2, error)
        end if

        ! Accept incoming endpoint values from other tasks.  Note that
        ! these are blocking receives, because we can't run the next step
        ! of the Jacobi iteration until we've received all the
        ! incoming data.

        if (my_id < num_tasks-1) then
            ! Receive right endpoint value
            call mpi_recv(u_old(end+1), 1, MPI_DOUBLE_PRECISION, my_id + 1, &
                1, MPI_COMM_WORLD, mpi_status, error)
        end if
        if (my_id > 0) then
            ! Receive left endpoint value
            call mpi_recv(u_old(start-1), 1, MPI_DOUBLE_PRECISION, my_id - 1, &
                2, MPI_COMM_WORLD, mpi_status, error)
        end if

        du_max_task = 0.d0   ! Max seen by this task

        ! Apply Jacobi iteration on this task's section of the array
        do i = start, end
            u(i) = 0.5d0*(u_old(i-1) + u_old(i+1) - dx**2*f(i))
            du_max_task = max(du_max_task, abs(u(i) - u_old(i)))
        end do

        ! Take global maximum of dumax values
        call mpi_allreduce(du_max_task, du_max_global, 1,       &
                           MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, error)
        ! Note that this MPI_ALLREDUCE call acts as an implicit barrier,
        ! since no process can return from it until all processes
        ! have called it.  Because of this, after this call we know
        ! that all the send and receive operations initiated at the
        ! top of the loop have finished -- all the MPI_RECV calls have
        ! finished in order for each process to get here, and if the
        ! MPI_RECV calls have finished, the corresponding MPI_ISEND
        ! calls have also finished.  Thus we can safely modify u_old
        ! again.

        ! Also periodically report progress to the user
        if (my_id == 0) then
            if (mod(num_iterations, PRINT_INTERVAL)==0) then
                print '("After ",i8," iterations, dumax = ",d16.6,/)', &
                    num_iterations, du_max_global
            end if
        end if

        ! All tasks now have du_max_global, and can check for convergence
        if (du_max_global < tolerance) exit
    end do

    print '("Task number ",i2," finished after ",i9," iterations, dumax = ",&
            e16.6)', my_id, num_iterations, du_max_global

    ! Output result:
    ! --------------

    ! Note: this only works if all processes share a file system
    ! and can all open and write to the same file!

    ! Synchronize to keep the next part from being non-deterministic
    call mpi_barrier(MPI_COMM_WORLD, error)

    ! Check to make sure that we were successful
    if (num_iterations >= MAX_ITERATIONS) then
        if (my_id == 0) then
            print *, "Jacobi failed to converge!"
            print *, "Reached du_max = ", du_max_global
            print *, "Tolerance = ", tolerance
        end if
        call mpi_finalize(error)
        stop
    endif

    ! Have each task output to a file in sequence, using messages to
    ! coordinate

    if (my_id == 0) then    ! Task 0 goes first
        ! Open file for writing, replacing any previous version:
        open(unit=20, file="jacobi_mpi.txt", status="replace")
        write(20, '(2e20.10)') 0.d0, u(0)    ! Boundary value at left end

        do i = start, end
            write(20, '(2e20.10)') i * dx, u(i)
        end do

        close(unit=20)
        ! Closing the file should guarantee that all the ouput
        ! will be written to disk.
        ! If the file isn't closed before the next process starts writing,
        ! output may be jumbled or missing.

        ! Send go-ahead message to next task
        ! Only the fact that the message was sent is important, not its contents
        ! so we send the special address MPI_BOTTOM and length 0.
        ! tag=4 is used for this message.

        if (num_tasks > 1) then
            call mpi_send(MPI_BOTTOM, 0, MPI_INTEGER, 1, 4, &
                          MPI_COMM_WORLD, error)
            endif

    else
        ! Wait for go-ahead message from previous task
        call mpi_recv(MPI_BOTTOM, 0, MPI_INTEGER, my_id - 1, 4, &
                          MPI_COMM_WORLD, mpi_status, error)
        ! Open file for appending; do not destroy previous contents
        open(unit=20, file="jacobi_mpi.txt", status="old", access="append")
        do i = start, end
            write(20, '(2e20.10)') i * dx, u(i)
        end do

        ! Boundary value at right end:
        if (my_id == num_tasks - 1) write(20, '(2e20.10)') 1.d0, u(end + 1)

        ! Flush all pending writes to disk
        close(unit=20)

        if (my_id < num_tasks - 1) then
            ! Send go-ahead message to next task
            call mpi_send(MPI_BOTTOM, 0, MPI_INTEGER, my_id + 1, 4, &
                          MPI_COMM_WORLD, error)
        end if
    end if

    ! Close out MPI
    call mpi_finalize(error)

end program jacobi_mpi


module mod_initial

  use iso_fortran_env, only: int32, real32
  implicit none

  private
  public :: set_gaussian

contains

  pure subroutine set_gaussian(x, icenter, decay)
    ! Sets the values of x to a Gaussian shape centered on icenter
    ! that decays with the given input decay.
    real(real32), intent(in out) :: x(:)
    integer(int32), intent(in) :: icenter
    real(real32), intent(in) :: decay
    integer(int32) :: i
    do concurrent(i = 1:size(x))
      x(i) = exp(-decay * (i - icenter)**2)
    end do
  end subroutine set_gaussian

end module mod_initial


!> @brief This subroutine solves a REAL128 quadratic equation of the form "ax2 + bx + c = 0".
!>
!> @param[in] a The first coefficient
!>
!> @param[in] b The second coefficient
!>
!> @param[in] c The third coefficient
!>
!> @param[out] x1 The first solution
!>
!> @param[out] x2 The second solution
!>
!> @note For a concise explanation see https://people.csail.mit.edu/bkph/articles/Quadratics.pdf by B.K.P. Horn (see https://people.csail.mit.edu/bkph/).
!>

PURE SUBROUTINE sub_solve_quadratic_REAL128_equation(a, b, c, x1, x2)
    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    REAL(kind = REAL128), INTENT(in)                                            :: a
    REAL(kind = REAL128), INTENT(in)                                            :: b
    REAL(kind = REAL128), INTENT(in)                                            :: c
    REAL(kind = REAL128), INTENT(out)                                           :: x1
    REAL(kind = REAL128), INTENT(out)                                           :: x2

    ! Check sign of b ...
    IF(b >= 0.0e0_REAL128)THEN
        x1 = (-b - SQRT(b ** 2 - 4.0e0_REAL128 * a * c)) / (2.0e0_REAL128 * a)
        x2 = (2.0e0_REAL128 * c) / (-b - SQRT(b ** 2 - 4.0e0_REAL128 * a * c))
    ELSE
        x1 = (2.0e0_REAL128 * c) / (-b + SQRT(b ** 2 - 4.0e0_REAL128 * a * c))
        x2 = (-b + SQRT(b ** 2 - 4.0e0_REAL128 * a * c)) / (2.0e0_REAL128 * a)
    END IF
END SUBROUTINE sub_solve_quadratic_REAL128_equation


subroutine utm2grd(ix,iy,e,n,box,nx,ny)
! convert utm coordinates e, n to grid number ix, iy
! given the four corners of the rectangle in box
! and the total global grid number nx, ny
! input: e, n
! output: ix, iy

! 2006-11-27
! Po Chen, Lamont
  implicit none
  integer ix, iy, nx, ny
  double precision, dimension(4,2) :: box
  double precision lx, ly, e, n, x, y, a, b, c, d, dx, dy, l

  lx=sqrt((box(4,1)-box(1,1))**2+(box(4,2)-box(1,2))**2)
  ly=sqrt((box(2,1)-box(1,1))**2+(box(2,2)-box(1,2))**2)
  dx=lx/(nx-1)
  dy=ly/(ny-1)

  a=(lx/(box(4,2)-box(1,2)))/((box(4,1)-box(1,1))/(box(4,2)-box(1,2))-(box(2,1)-box(1,1))/(box(2,2)-box(1,2)))
  b=-a*(box(2,1)-box(1,1))/(box(2,2)-box(1,2))
  c=(ly/(box(2,2)-box(1,2)))/((box(2,1)-box(1,1))/(box(2,2)-box(1,2))-(box(4,1)-box(1,1))/(box(4,2)-box(1,2)))
  d=-c*(box(4,1)-box(1,1))/(box(4,2)-box(1,2))

  x=a*(e-box(1,1))+b*(n-box(1,2))
  y=c*(e-box(1,1))+d*(n-box(1,2))
  ix=nint(x/dx)+1
  iy=nint(y/dy)+1
  return
end subroutine utm2grd

subroutine utm2grd_d(ix,iy,e,n,box,nx,ny)
! convert utm coordinates e, n to grid number ix, iy
! given the four corners of the rectangle in box
! and the total global grid number nx, ny
! input: e, n
! output: ix, iy

! 2006-11-27
! Po Chen, Lamont
  implicit none
  integer nx, ny
  double precision, dimension(4,2) :: box
  double precision ix, iy, lx, ly, e, n, x, y, a, b, c, d, dx, dy, l

  lx=sqrt((box(4,1)-box(1,1))**2+(box(4,2)-box(1,2))**2)
  ly=sqrt((box(2,1)-box(1,1))**2+(box(2,2)-box(1,2))**2)
  dx=lx/(nx-1)
  dy=ly/(ny-1)

  a=(lx/(box(4,2)-box(1,2)))/((box(4,1)-box(1,1))/(box(4,2)-box(1,2))-(box(2,1)-box(1,1))/(box(2,2)-box(1,2)))
  b=-a*(box(2,1)-box(1,1))/(box(2,2)-box(1,2))
  c=(ly/(box(2,2)-box(1,2)))/((box(2,1)-box(1,1))/(box(2,2)-box(1,2))-(box(4,1)-box(1,1))/(box(4,2)-box(1,2)))
  d=-c*(box(4,1)-box(1,1))/(box(4,2)-box(1,2))

  x=a*(e-box(1,1))+b*(n-box(1,2))
  y=c*(e-box(1,1))+d*(n-box(1,2))
  ix=(x/dx)+1
  iy=(y/dy)+1
  return
end subroutine utm2grd_d


| bench.f - sum of 5000 sines
." Sum of sin(1) + sin(2) + ... + sin(5000) (angles in radians)" cr cr

10000 constant loopsize
variable start-time

floats
finit

: smr
finit
f0
do
i s>f fsin f+
loop
;

: once
do
5001 1 smr
loop
;

: bench
loopsize 1 + 1 once
;

finit
19 sigdig !

f1 fsin 5000 s>f fsin f+ 5001 s>f fsin f-
| fdup f.      ."  numerator" cr
f1 fdup f+ fdup f1 fcos f* f-
| fdup f. ."  denominator" cr cr
f/
f. ."  answer by formula" cr cr

ms@ start-time !
bench
ms@ f. ."  answer by summing" cr
3 sigdig !
s>f start-time @ s>f f- loopsize s>f f/ f. ." milliseconds" cr

bye


plus = fix (
  \f:Nat->Nat->Nat m:Nat n:Nat.
    if iszero m
      then n
      else f (pred m) (succ n)
  );

times = fix (
  \f:Nat->Nat->Nat. \m:Nat. \n:Nat.
    if iszero m
      then 0
      else plus n (f (pred m) n)
  );

factorial = fix (
  \f:Nat->Nat m:Nat.
    if iszero m
      then 1
      else times m (f (pred m))
  );

plus 10 0;
plus 5 6;
plus 0 12;

times 5 10;
factorial 10;
factorial 5;


! (C) Copyright 2019 UCAR and 2011-2018 John Thuburn, University of Exeter, UK
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.

module femps_utils_mod

use femps_kinds_mod

implicit none

public

interface ll2xyz
   module procedure ll2xyz_sca
   module procedure ll2xyz_vec
end interface

interface xyz2ll
   module procedure xyz2ll_sca
   module procedure xyz2ll_vec
end interface

integer, parameter :: fatal = 1, trace = 2

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

contains

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

subroutine ll2xyz_sca(long,lat,x,y,z)

! To convert longitude and latitude to cartesian coordinates
! on the unit sphere

implicit none
real(kind=kind_real), intent(in)  :: long,lat
real(kind=kind_real), intent(out) :: x, y, z

real(kind=kind_real) :: cln,sln,clt,slt

sln=sin(long)
cln=cos(long)
slt=sin(lat)
clt=cos(lat)

x=cln*clt
y=sln*clt
z=slt

end subroutine ll2xyz_sca

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

subroutine ll2xyz_vec(long,lat,x)

implicit none
real(kind=kind_real), intent(in)  :: long,lat
real(kind=kind_real), intent(out) :: x(3)

call ll2xyz_sca(long,lat,x(1),x(2),x(3))

end subroutine ll2xyz_vec

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

subroutine xyz2ll_sca(x,y,z,long,lat)

implicit none
real(kind=kind_real), intent(in)  :: x,y,z
real(kind=kind_real), intent(out) :: long,lat

real(kind=kind_real) :: pi,tln,tlt,r

! To convert cartesian coordinates to longitude and latitude
! ----------------------------------------------------------

pi=4.0_kind_real*atan(1.0_kind_real)

if (x.eq.0.0_kind_real) then
  if (y.ge.0.0_kind_real) then
    long=0.5_kind_real*pi
  else
    long=1.5_kind_real*pi
  endif
else
  tln=y/x
  long=atan(tln)
  if (x.lt.0.0_kind_real) then
    long=long+pi
  endif
  if (long.lt.0.0_kind_real) then
    long=long+2.0_kind_real*pi
  endif
endif

r=sqrt(x*x+y*y)
if (r.eq.0.0_kind_real) then
  if (z.gt.0.0_kind_real) then
    lat=0.5_kind_real*pi
  else
    lat=-0.5_kind_real*pi
  endif
else
  tlt=z/r
  lat=atan(tlt)
endif

end subroutine xyz2ll_sca

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

subroutine xyz2ll_vec(x,long,lat)

implicit none
real(kind=kind_real), intent(in)  :: x(3)
real(kind=kind_real), intent(out) :: long,lat

call xyz2ll_sca(x(1),x(2),x(3),long,lat)

end subroutine xyz2ll_vec

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

subroutine starea2(x0,y0,z0,x1,y1,z1,x2,y2,z2,area)

implicit none
real(kind=kind_real), intent(in)  :: x0, x1, x2
real(kind=kind_real), intent(in)  :: y0, y1, y2
real(kind=kind_real), intent(in)  :: z0, z1, z2
real(kind=kind_real), intent(out) :: area

real(kind=kind_real) :: d0,d1,d2,s,t0,t1,t2,t3

! Calculate the area of the spherical triangle whose corners
! have Cartesian coordinates (X0,Y0,Z0), (X1,Y1,Z1), (X2,Y2,Z2)
! The formula below is more robust to roundoff error than the
! better known sum of angle - PI formula

! Distances between pairs of points
call spdist(x0,y0,z0,x1,y1,z1,d2)
call spdist(x1,y1,z1,x2,y2,z2,d0)
call spdist(x2,y2,z2,x0,y0,z0,d1)

! Half perimeter
s=0.5_kind_real*(d0+d1+d2)

! Tangents
t0 = tan(0.5_kind_real*(s-d0))
t1 = tan(0.5_kind_real*(s-d1))
t2 = tan(0.5_kind_real*(s-d2))
t3 = tan(0.5_kind_real*s)

! Area
area = 4.0_kind_real*atan(sqrt(t0*t1*t2*t3))

end subroutine starea2

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

subroutine spdist(x1,y1,z1,x2,y2,z2,s)

implicit none
real(kind=kind_real), intent(in)  :: x1, x2
real(kind=kind_real), intent(in)  :: y1, y2
real(kind=kind_real), intent(in)  :: z1, z2
real(kind=kind_real), intent(out) :: s

real(kind=kind_real) :: dx, dy, dz, ad

! Calculate the spherical distance S between two points with Cartesian
! coordinates (X1,Y1,Z1), (X2,Y2,Z2) on the unit sphere

dx = x2 - x1
dy = y2 - y1
dz = z2 - z1
ad = sqrt(dx*dx + dy*dy + dz*dz)
s = 2.0_kind_real*asin(0.5_kind_real*ad)

end subroutine spdist

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

subroutine addtab(dim1,dim2,tab,index,tabentry)

implicit none
integer, intent(in)    :: dim1,dim2
integer, intent(inout) :: tab(dim1,dim2)
integer, intent(in)    :: index
integer, intent(in)    :: tabentry

integer :: i
character(len=2056) :: errormessage

! Add an entry to a table
! -----------------------

i=0
100 continue
i=i+1
if (i.gt.dim2) then
  call message('**********')
  call message('table full')
  call message('**********')
  write(errormessage,*) index,tabentry,dim1,dim2
  call message(errormessage)
  write(errormessage,*) tab(index,:)
  call message(errormessage,fatal)
endif
if (tab(index,i).ne.0) goto 100
tab(index,i)=tabentry

end subroutine addtab

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

subroutine findinlist(i,list,nl,ix)

implicit none
integer, intent(in)    :: i
integer, intent(in)    :: nl
integer, intent(inout) :: list(nl)
integer, intent(out)   :: ix

character(len=255) :: errormessage

! Find the index ix to the entry i in the input list.
! if i is not already in the list then it is added into
! the first empty (i.e. zero) position.

ix = 1
do while ((list(ix) .ne. i) .and. (list(ix) .ne. 0))
  if (ix == nl) then
    call message('search past end of list in subroutine findinlist.')
    write(errormessage,*) 'i = ',i
    call message(errormessage)
    write(errormessage,*) 'list = ',list
    call message(errormessage,fatal)
  endif
  ix = ix + 1
enddo
list(ix) = i

end subroutine findinlist

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

subroutine triangle(x1,x2,x3,l1sq,l2sq,l3sq,area)

implicit none
real(kind=kind_real), intent(in)  :: x1(3), x2(3), x3(3)
real(kind=kind_real), intent(out) :: l1sq, l2sq, l3sq, area

real(kind=kind_real) :: a, b, c

! Compute the squares of the lengths of the sides and the area of
! a triangle defined by three points x1, x2 and x3 in 3d euclidean
! space. Side 1 is opposite vertex 1, etc.

! squares of side by pythagoras
l1sq = (x2(1) - x3(1))**2 + (x2(2) - x3(2))**2 + (x2(3) - x3(3))**2
l2sq = (x3(1) - x1(1))**2 + (x3(2) - x1(2))**2 + (x3(3) - x1(3))**2
l3sq = (x1(1) - x2(1))**2 + (x1(2) - x2(2))**2 + (x1(3) - x2(3))**2

! area by heron's formula
a = sqrt(l1sq)
b = sqrt(l2sq)
c = sqrt(l3sq)
area = 0.25_kind_real*sqrt((a + b + c)*(b + c - a)*(c + a - b)*(a + b - c))

end subroutine triangle

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

subroutine nccheck(status,iam)

use netcdf

implicit none
integer,                    intent (in) :: status
character(len=*), optional, intent (in) :: iam

character(len=1024) :: error_descr

if(status /= nf90_noerr) then

  error_descr = "NetCDF error, aborting ... "

  if (present(iam)) then
    error_descr = trim(error_descr)//", "//trim(iam)
  endif

  error_descr = trim(error_descr)//". Error code: "//trim(nf90_strerror(status))

  call message('NCCheck'//trim(error_descr),fatal)

end if

end subroutine nccheck

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

subroutine message(note,code)

implicit none
character(len=*),  intent(in) :: note
integer, optional, intent(in) :: code

character(len=2056) :: noteprint

noteprint = note

if (present(code)) then
  if (code == fatal) then
    noteprint = 'FATAL: '//trim(note)
  elseif (code == trace) then
    !noteprint = 'TRACE: '//trim(note)
  endif
endif

!print*, trim(noteprint)

if (present(code)) then
  if (code == fatal) then
    print*, trim(noteprint)
    stop 1
  endif
endif

end subroutine message

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

end module femps_utils_mod


	REAL*4 FUNCTION
     .  TDELTASIZE(XITYPE,XALPHA,POWER,SIGMA,N,XM)
	USE MSIMSL
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine TDELTASIZE (see below)
C  Arguments:
C   input from user
C	ALPHA	(real)	Type I error probability (two tailed)
C	POWER	(real)	The desired statistical power
C	N	(real)	Number of patients per group for independent
C			t-tests or the number of pairs of patients
C			for paired t-tests
C	M	(real)  the number of control patients per experimental
C			patient.  M is only defined for independent t-tests.
C	SIGMA	(real)  An estimate of the within group standard deviation for
C			independent tests.  It is an estimate of the standard
C			deviation of paired response differences for paired
C			data.
C   output:
C	TDELTASIZE(real)a difference in population means that can be
C			detected with power POWER given N pairs of
C			patients, or N experimental patients with M
C			controls per experimental patient and a type I
C			error probability ALPHA
C  Notes:
C
C   .	Reference:
C
C	Steel and Torrie: Principles and Procedures
C	of Statistics a Biometrical Approach, 2nd edition, New York:
C	McGraw-Hill 1980.  Critical values from the appropriate
C	t distribution are used rather that the z distribution.
C
C	The value of DIFF is derived using elementary methods.  The
C	validity of these computations may be confirmed using subroutine
C	TSAMPLESIZE.
C
C	TCRVALUE(P,NU) returns the critical value that is exceeded
C	by a t statistic with NU degrees of freedom with probability P.
C
C	Let TCUM(T,NU) return the probability that a t statistic
C	with NU degrees of freedom will exceed T.
C
C	The resulting power calculations produced by this program
C	are in close agreement with those obtained from Table 10 of
C	Pearson and Hartley, Biometrika Tables for Statisticians, Vol I,
C	3rd Ed., Cambridge:  Cambridge U. Press, 1970.
C   .	This routine was written by Dale Plummer
C   .	Designed by William Dupont
C
C-Declarations----------------------------------------------------------
C
C  Arguments
C
	INTEGER XITYPE
	REAL XALPHA,POWER,SIGMA,N,XM
C
C  Functions
C
	REAL TCRVALUE
C
C  Common used to pass needed values to passed name functions.
C
	INTEGER ITYPE
	REAL ALPHA, MYBETA, DELTA, M, NU
	COMMON /TSSCOMM/ ALPHA, MYBETA, DELTA, M, NU, ITYPE
C
C-Code------------------------------------------------------------------
C
	ALPHA=XALPHA
	ITYPE=XITYPE
	M=XM
C
C    Perform the calculations.
C
	IF (ITYPE.EQ.1) THEN
C
C    Do for paired design.
C    Input is ALPHA, POWER, SIGMA, and N:  '
C
	    MYBETA=1.-POWER
	    NU=N-1
C	    DELTA=(TCRVALUE(MYBETA,NU)+TCRVALUE(ALPHA/2.,NU))/SQRT(N)
	    DELTA=(TIN((1.-MYBETA),NU)+TIN((1.-ALPHA/2.),NU))/SQRT(N)
	    TDELTASIZE=DELTA*SIGMA
	ELSE
C
C    Do for independent design.
C    Input is ALPHA, POWER, SIGMA, N, and M:  '
C
	    MYBETA=1.-POWER
	    NU=N*(M+1)-2
C	    DELTA=(TCRVALUE(MYBETA,NU)+TCRVALUE(ALPHA/2.,NU))/SQRT(N)
	    DELTA=(TIN((1.-MYBETA),NU)+TIN((1.-ALPHA/2.),NU))/SQRT(N)
	    TDELTASIZE=DELTA*SIGMA*SQRT(1.+1./M)
	END IF
	RETURN
	END


SUBROUTINE vel2acc(in_data,dt,nt,out_data)
!---------------------------------------------------------------------------
!
! Description:
!   from vel2acc.m
!
!
!
! Dependencies:
!
!   None.
!
! Author: R. Takedatsu
!
! Modified: February 2019 (v2.0)
!

use def_kind;

implicit none

! local variables
integer(kind=i_single),intent(in)             :: nt
integer(kind=i_single)                        :: k
real(kind=r_single),intent(in)                :: dt
real(kind=r_single),dimension(nt),intent(in)  :: in_data
real(kind=r_single),dimension(nt),intent(out) :: out_data

! Originally whitten by D. Roten in Matlab code
!function [acc]=vel2acc(vel, dt)
!   nt=length(vel);
!   acc=zeros(nt, 1);
!   for k=2:nt
!      acc(k)=(vel(k) - vel(k-1))/dt;
!   end
!   return

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

out_data(1:nt)=0

do k=2,nt
   out_data(k)=(in_data(k) - in_data(k-1)) / dt
enddo

END SUBROUTINE vel2acc

!===================================================================================================

SUBROUTINE acc2velc(ival,in_data,dt,nt,out_data)
!---------------------------------------------------------------------------
!
! Description:
!   from acc2velc.m
!
!
!
! Dependencies:
!
!   None.
!
! Author: R. Takedatsu
!
! Modified: February 2019 (v2.0)
!

use def_kind;

implicit none

! local variables
integer(kind=i_single),intent(in)             :: nt
integer(kind=i_single)                        :: k
real(kind=r_single),intent(in)                :: ival ! initial velocity value
real(kind=r_single),intent(in)                :: dt
real(kind=r_single),dimension(nt),intent(in)  :: in_data
real(kind=r_single),dimension(nt),intent(out) :: out_data

! Originally whitten by D. Roten in Matlab code
!function [velc]=acc2velc(vel, acc, dt)
!   nt=length(acc);
!   velc=zeros(nt, 1);
!   velc(1)= vel(1);
!   for k=2:nt
!       velc(k)=velc(k-1)+acc(k)*dt;
!   end

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

out_data(1:nt)=0
out_data(1)=ival

do k=2,nt
   out_data(k)=out_data(k-1) + in_data(k)* dt
enddo

END SUBROUTINE acc2velc

!===================================================================================================