! This program calculates the matrix elements of the positronium-hydrogen
!  matrices (similar to equation 2.15 of the Armour and Humberston article).  Specifically,
!  we are calculating elements of the form (phi_i, L phi_j) as in equation (3.22).
! This does use OpenMP to speed up computation on multicore processors, so some familiarity
!  with parallel programming is required to understand the !$omp lines.
! A future speed-up could be done with Open MPI (as is done for the energy code), but this
!  computation is usually done in a few hours.

! TODO: Make MaxIter and the 4 come from the configuration file.

module WLimits
   implicit none
   integer lmin, lmax
   integer mmin, mmax
   integer nmin, nmax
end module WLimits

program PsHMain
	use WLimits
	implicit none

	interface
		integer(c_int) function optimizewavefn(MaxIter, Omega, NumTerms, M12max, M23max, M31max, pmax, IsTriplet, Ordering, Method, EigenRoutine, alpha, beta, gamma) bind(c, name='optimizewavefn')
		use iso_c_binding
		integer(c_int), value :: MaxIter, Omega, NumTerms, M12max, M23max, M31max, pmax, IsTriplet, Ordering, Method, EigenRoutine
		real(c_double), value :: alpha, beta, gamma
		end function optimizewavefn
	end interface

	real*16 omp_get_wtime
	integer Omega  ! This sets the limits on the terms.
	integer NumTerms  ! Number of terms in our Hylleraas expansion
	integer iread, iwrite  ! Our input and output files
	integer CalcPowerTableSize
	real*16, allocatable, dimension(:,:) :: PhiPhi, Phi2HPhi
	real*8, allocatable, dimension(:,:) :: PhiPhi8, Phi2HPhi8
	real*8, allocatable, dimension(:) :: Energies, Workspace
	real*16 Alpha, Beta, Gamma, Prev
	integer, allocatable, dimension(:) :: UsedTerms
	integer NumUsed, i, j, k, n
	real*8 StartTime, EndTime
	integer iargc, IsTriplet, Method, LowerEigen, UpperEigen, Info, AllEnergies, EigenRoutine
	character *100 IOBuffer
	integer Optimize, EigenNum, Ordering, Iter, MaxIter, MaxIterOuter, M12max, M23max, M31max, pmax, StartEnergy, LValue
	real*16 Tol, Err, h, EDeriv, fa, fh, y, Divisor, ederivwrapper
	real*16, dimension(3) :: Del, Delta, f1, f0, x1, x0, x, C31, C13
	real*16, dimension(3,3) :: B, BTemp, C33, Jacob
    real*16 ThreeJSymbol, HylleraasIntegralGeneral

!	real*16, allocatable, dimension(:,:,:,:) :: WMatrix
!	call GenFactorial(400)
!	lmin = 1;  lmax = 1
!	mmin = 1;  mmax = 1
!	nmin = 1;  nmax = 1
!	allocate(WMatrix(lmin:lmax, mmin:mmax, nmin:nmax, 6))
!    write (*,*) HylleraasIntegralGeneral(.true., .false., 2, 2, 0, -1, 1, 1, 1.0q0, 1.2q0, 2.2q0, &
!								2, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 10, 150, 5, 51, 0, 0, 0, WMatrix, 1)
!    deallocate(WMatrix)

	iread = 9
	iwrite = 10
	! This allows the possibility of using different input and output files than the defaults.
	!  This mainly lets me run this program on multiple computers at the same time without
	!  one overwriting the results from another.  If the program is called without any
	!  command-line arguments, it uses the default filenames.
	if (iargc() == 2) then
		call getarg(1, IOBuffer)
		open(iread, FILE=IOBuffer)
		call getarg(2, IOBuffer)
		open(iwrite, FILE=IOBuffer)
	else
		open(iread, FILE='input.txt')
		open(iwrite, FILE='output.txt')
	endif

	! Read the input parameters.
	call ReadParamFile(iread, Omega, LValue, Alpha, Beta, Gamma, M12max, M23max, M31max, pmax, Method, IsTriplet, LowerEigen, UpperEigen, &
						 AllEnergies, Optimize, EigenNum, MaxIter, Ordering, EigenRoutine)

	if (IsTriplet /= 0 .and. IsTriplet /= 1) then
		write (*,*) 'Must choose between singlet and triplet calculation - exiting.'
		stop
	endif

	if (Optimize == 1) write (iwrite,*) 'Optimizing eigenvalue', EigenNum

	Tol = 1e-3
	Err = 1  ! Just has to be larger than tol.
	h = 1e-5

	! Get the start time to determine the duration of the program.
	!call cpu_time(StartTime)
	StartTime = omp_get_wtime()

	NumTerms = CalcPowerTableSize(Omega) * 2  ! First and second symmetries
	call WriteHeader(iwrite, LValue, IsTriplet, Ordering, Method, EigenRoutine, Omega, NumTerms, Alpha, Beta, Gamma, M12max, M23max, M31max, pmax)

	write (*,*) 'NumTerms:', NumTerms
	allocate(PhiPhi(NumTerms,NumTerms))
	allocate(Phi2HPhi(NumTerms,NumTerms))
	allocate(PhiPhi8(NumTerms,NumTerms))
	allocate(Phi2HPhi8(NumTerms,NumTerms))
	allocate(Energies(NumTerms))
	allocate(Workspace(3*NumTerms-1))

	if (Omega == -1) then
		goto 200  ! No short-range terms, so no need to do these calculations (just a header)
	end if

	if (Optimize == 1) then
		! TODO: Add these back in.
		!fa = optimizewavefn(MaxIter, Omega, NumTerms, M12max, M23max, M31max, pmax, IsTriplet, Ordering, Method, EigenRoutine, Alpha, Beta, Gamma)
		!fa = EDeriv(Omega, NumTerms, Alpha, Beta, Gamma, EigenNum, PhiPhi, Phi2HPhi, M12max, pmax, 0, &
		!			IsTriplet, Ordering, Method)
	else
		! If we are not optimizing eigenvalues, we can still call the same function, which exits early with PhiPhi and Phi2HPhi filled.
		fa = EDeriv(Omega, NumTerms, Alpha, Beta, Gamma, EigenNum, PhiPhi, Phi2HPhi, M12max, M23max, M31max, pmax, 0, &
					IsTriplet, Ordering, Method, EigenRoutine, LValue)
		write (*,*) fa
    endif

    if (LValue == 0) then  ! S-wave only has one symmetry
        NumTerms = NumTerms / 2
    end if

	do i = 1, NumTerms, 1
		!do j = 1, i, 1  ! Use this instead if only the lower triangle is required.
		do j = 1, NumTerms, 1
			write (iwrite,"(i6,i6,d38.30,d38.30)") i, j, PhiPhi(i,j), Phi2HPhi(i,j)
		enddo
	enddo

	! Divide every entry in Phi2HPhi by 2, since we calculated <phi_i|2H|phi_j> in equation (3.22).
	Phi2HPhi = Phi2HPhi / 2.0_16

	write (iwrite,*)
	write (iwrite,*) 'Energies:'

	if (AllEnergies == 0) then
        StartEnergy = NumTerms
	else
		StartEnergy = 1
    end if

    if (LValue == 0) then
        NumTerms = NumTerms * 2
    end if

	do j = StartEnergy, NumTerms, 1
	    if (LValue == 0 .and. j > NumTerms / 2) then  ! S-wave only has one symmetry
            exit
        end if
		! Copies our real*16 matrices to real*8 matrices so that LAPACK can operate on them.
		Phi2HPhi8 = Phi2HPhi
		PhiPhi8 = PhiPhi

		! This calculates the energy eigenvalues of the generalized eigenvalue problem generated from
		!  the Rayleigh-Ritz variational method:
		!  det(<phi_i|H|phi_j> - E <phi_i|phi_j>) = 0
		! We calculated the lower and upper triangles of the PhiPhi and Phi2HPhi matrices above, though
		!  they are symmetric.  LAPACK does not require us to fill in both halves; we can just
		!  specify 'L' in the third parameter to denote that the lower triangle (and diagonal) is filled.
		! Explanation of choices for the parameters are found at the Netlib site:
		!  http://www.netlib.org/lapack/double/dsygv.f
		call dsygv(1, 'N', 'L', j, Phi2HPhi8, NumTerms, PhiPhi8, NumTerms, Energies, Workspace, 3*NumTerms-1, Info)
		!call Newdsygv(1, 'N', 'L', j, Phi2HPhi, NumTerms, PhiPhi, NumTerms, Energies, Workspace, 3*NumTerms-1, Info)
		!call nag_sym_gen_eig_all('L', Phi2HPhi8, PhiPhi8, Energies)  ! NAG equivalent
		if (Info /= 0) then
			write (*,*)
			write (*,*) 'Energy eigenvalues could not be determined!'
			write (*,*) 'dsygv error code:', Info
			write (iwrite,*)
			write (iwrite,*) 'Energy eigenvalues could not be determined!'
			write (iwrite,*) 'dsygv error code:', Info
			exit  ! Exit the loop, because every successive j will give the same error, since we have a troublesome term.
		elseif (Info == 0) then  ! dsygv successfully completed.
			! Writes the eigenvalues.
			! This output is formatted properly for inclusion into Excel as a comma-separated value (.csv) file.
			write (iwrite,"(i4)",advance='no') j
			do i = LowerEigen, UpperEigen, 1
				write (iwrite,"(a,d21.14)",advance='no') ', ', Energies(i)
			enddo
			write (iwrite,*) ' '  ! Finish the line

			write (*,"(i4)",advance='no') j
			do i = LowerEigen, UpperEigen, 1
				write (*,"(a,d21.14)",advance='no') ', ', Energies(i)
			enddo
			write (*,*) ' '  ! Finish the line
		endif
	enddo

	! Get the end time to find the duration of the program.
	!call cpu_time(EndTime)
200	EndTime = omp_get_wtime()
	write (*,*) 'Time taken (s):', EndTime - StartTime
	write (iwrite,*)
	write (iwrite,*) 'Time taken (s):', EndTime - StartTime, '  (min):', (EndTime - StartTime) / 60.0

	! Clean up memory before exiting
	deallocate(Workspace)
	deallocate(Energies)
	deallocate(PhiPhi8)
	deallocate(Phi2HPhi8)
	deallocate(PhiPhi)
	deallocate(Phi2HPhi)

	! Close file handles
	close(iwrite)

	stop
end

subroutine ReadParamFile(iread, Omega, LValue, Alpha, Beta, Gamma, M12max, M23max, M31max, pmax, Method, IsTriplet, LowerEigen, UpperEigen, &
						 AllEnergies, Optimize, EigenNum, MaxIter, Ordering, EigenRoutine)
	implicit none
	integer iread, LValue, Omega, Method, M12max, M23max, M31max, pmax, IsTriplet, LowerEigen, UpperEigen, AllEnergies
	integer Optimize, EigenNum, MaxIter, Ordering, EigenRoutine
	real*16 Alpha, Beta, Gamma

	read (iread,*) ! Description line
	read (iread,*) Omega
	read (iread,*) ! Description line
	read (iread,*) LValue
	read (iread,*)
	read (iread,*) Alpha
	read (iread,*) Beta
	read (iread,*) Gamma
	read (iread,*)
	read (iread,*) Method
	read (iread,*)
	read (iread,*) M12max, M23max, M31max
	read (iread,*)
	read (iread,*) pmax
	read (iread,*)
	read (iread,*) IsTriplet
	read (iread,*)
	read (iread,*) LowerEigen, UpperEigen
	read (iread,*)
	read (iread,*) AllEnergies
	read (iread,*)
	read (iread,*) Optimize
	read (iread,*)
	read (iread,*) EigenNum
	read (iread,*)
	read (iread,*) MaxIter
	read (iread,*)
	read (iread,*) Ordering
	read (iread,*)
	read (iread,*) EigenRoutine
	close (iread)

	return
end

subroutine WriteHeader(iwrite, LValue, IsTriplet, Ordering, Method, EigenRoutine, Omega, NumTerms, Alpha, Beta, Gamma, M12max, M23max, M31max, pmax)
	implicit none
	integer iwrite, LValue, IsTriplet, Ordering, Method, EigenRoutine, Omega, NumTerms, M12max, M23max, M31max, pmax
	real*16 Alpha, Beta, Gamma

	select case (LValue)
		case (0)  ! S-Wave
			if (IsTriplet == 0) then
				write (*,*) "S-Wave Singlet Ps-H"
				write (iwrite,*) "S-Wave Singlet Ps-H"
			else
				write (*,*) "S-Wave Triplet Ps-H"
				write (iwrite,*) "S-Wave Triplet Ps-H"
			endif
		case (1)
			if (IsTriplet == 0) then
				write (*,*) "P-Wave Singlet Ps-H: 1st formalism"
				write (iwrite,*) "P-Wave Singlet Ps-H: 1st formalism"
			else
				write (*,*) "P-Wave Triplet Ps-H: 1st formalism"
				write (iwrite,*) "P-Wave Triplet Ps-H: 1st formalism"
			endif
		case (2)
			if (IsTriplet == 0) then
				write (*,*) "D-Wave Singlet Ps-H: 1st formalism"
				write (iwrite,*) "D-Wave Singlet Ps-H: 1st formalism"
			else
				write (*,*) "D-Wave Triplet Ps-H: 1st formalism"
				write (iwrite,*) "D-Wave Triplet Ps-H: 1st formalism"
			endif
		case (3)  ! F-Wave
			if (IsTriplet == 0) then
				write (*,*) "F-Wave Singlet Ps-H"
				write (iwrite,*) "F-Wave Singlet Ps-H"
			else
				write (*,*) "F-Wave Triplet Ps-H"
				write (iwrite,*) "F-Wave Triplet Ps-H"
			endif
		case (4)  ! G-Wave
			if (IsTriplet == 0) then
				write (*,*) "G-Wave Singlet Ps-H"
				write (iwrite,*) "G-Wave Singlet Ps-H"
			else
				write (*,*) "G-Wave Triplet Ps-H"
				write (iwrite,*) "G-Wave Triplet Ps-H"
			endif
		case (5)  ! H-Wave
			if (IsTriplet == 0) then
				write (*,*) "H-Wave Singlet Ps-H"
				write (iwrite,*) "H-Wave Singlet Ps-H"
			else
				write (*,*) "H-Wave Triplet Ps-H"
				write (iwrite,*) "H-Wave Triplet Ps-H"
			endif
		case (6)  ! I-Wave
			if (IsTriplet == 0) then
				write (*,*) "I-Wave Singlet Ps-H"
				write (iwrite,*) "I-Wave Singlet Ps-H"
			else
				write (*,*) "I-Wave Triplet Ps-H"
				write (iwrite,*) "I-Wave Triplet Ps-H"
			endif
		case (7)  ! K-Wave
			if (IsTriplet == 0) then
				write (*,*) "K-Wave Singlet Ps-H"
				write (iwrite,*) "K-Wave Singlet Ps-H"
			else
				write (*,*) "K-Wave Triplet Ps-H"
				write (iwrite,*) "K-Wave Triplet Ps-H"
			endif
		case (8)  ! L-Wave
			if (IsTriplet == 0) then
				write (*,*) "L-Wave Singlet Ps-H"
				write (iwrite,*) "L-Wave Singlet Ps-H"
			else
				write (*,*) "L-Wave Triplet Ps-H"
				write (iwrite,*) "L-Wave Triplet Ps-H"
			endif
		case default
			write (*,*) "Higher partial waves are not supported yet...exiting."
			stop
	end select

	if (Ordering == 1) then
		write (*,*) "Using Peter Van Reeth's ordering"
		write (iwrite,*) "Using Peter Van Reeth's ordering"
	else
		write (*,*) "Using my ordering"
		write (iwrite,*) "Using my ordering"
	endif

	if (Method == 0) then
		write (*,*) "Integration Technique: Direct Summation"
		write (iwrite,*) "Integration Technique: Direct Summation"
	else if (Method == 1) then
		write (*,*) "Integration Technique: Asymptotic Expansion"
		write (iwrite,*) "Integration Technique: Asymptotic Expansion"
	else if (Method == 2) then
		write (*,*) "Integration Technique: Recursion Relations"
		write (iwrite,*) "Integration Technique: Recursion Relations"
	else
		write (*,*) "Method parameter in input file must be 0, 1 or 2."
		stop
	end if

	if (EigenRoutine == 1) then
		write (*,*) "Eigenvalue routine: dsygv from LAPACK"
		write (iwrite,*) "Eigenvalue routine: dsygv from LAPACK"
	else if (EigenRoutine == 2) then
		write (*,*) "Eigenvalue routine: Pachucki eigenproblem solver"
		write (iwrite,*) "Eigenvalue routine: Pachucki eigenproblem solver"
	else
		write (*,*) "Eigenvalue routine parameter in input file must be 1 or 2."
		stop
	end if

	write (iwrite,*) 'Omega =', Omega
	write (iwrite,*) 'Alpha =', Alpha
	write (iwrite,*) 'Beta =', Beta
	write (iwrite,*) 'Gamma =', Gamma

    if (LValue == 0) NumTerms = NumTerms / 2
	write (iwrite,*) 'Number of terms:', NumTerms
	write (*,*) 'Number of terms:', NumTerms
	write (*,*) 'Omega =', Omega
    if (LValue == 0) NumTerms = NumTerms * 2

	write (iwrite,*) 'M12max, M23max, M31max, pmax =', M12max, M23max, M31max, pmax
	write (iwrite,*)

	return
end

! This subroutine calculates the number of terms for the function GenOmegaPowerTable (below).  This
!  is needed to determine the size of the dynamically allocated table before it is produced.
integer function CalcPowerTableSize(Omega)
	implicit none
	integer Omega  ! This sets the limits on the terms.
	integer NumTerms  ! The total number of terms
	integer om, ki, li, mi, ni, pi, qi  ! These are the exponents we are determining.

	if (Omega == -1) then  ! Special case where we don't want any short-range terms
		CalcPowerTableSize = 0
		return
	end if

	NumTerms = 0
	do om = 0, Omega, 1
		do ki = 0, Omega, 1
			do li = 0, Omega, 1
				do mi = 0, Omega, 1
					do ni = 0, Omega, 1
						do pi = 0, Omega, 1
							do qi = 0, Omega, 1
								if (ki + li + mi + ni + pi + qi == om) then
									!if (ki>li) cycle
									!if (ki==li .and. qi>pi) cycle

!									if (om > 3 .and. qi > 0) cycle  ! Restrict r23 to max of 1
!									if (om > 3 .and. pi > 0) cycle  ! Restrict r13 to max of 3
!									if (om > 2 .and. ni > 0) cycle  ! Restrict r3 to max of 0
!									if (ki >= li .and. qi > pi) cycle  ! Check if r1>r2 and r23 > r13 (powers)
									NumTerms = NumTerms + 1
								endif
							enddo
						enddo
					enddo
				enddo
			enddo
		enddo
	enddo

	CalcPowerTableSize = NumTerms
	return
end

! This subroutine calculates values of k_i, l_i, m_i, n_i, p_i and q_i of
!  (3.14).  The summation of these is given by equation (3.15), but we do not have
!  the restriction on q of being even.
! This is written to always have the terms in order of increasing omega, i.e. the terms
!  for omega = 0 are first, etc.
! TODO: Use logical for Ordering
subroutine GenOmegaPowerTable(Omega, PowerTable, ArraySize, Ordering, l1, l2)
	!implicit none
	integer Omega  ! This sets the limits on the terms.
	integer ArraySize
	integer, dimension(ArraySize,6) :: PowerTable
	integer NumTerm  ! The number of the current term
	integer om, ki, li, mi, ni, pi, qi  ! These are the exponents we are determining.
	integer Ordering  ! Whether to use Peter's ordering or mine
	integer l1, l2, l3  ! l1 = 0 for S-wave, 1 for P-wave, etc.

	if (Ordering == 0) then  ! Use my ordering
		NumTerm = 0
		do om = 0, Omega, 1
			do ki = 0, Omega, 1
				do li = 0, Omega, 1
					do mi = 0, Omega, 1
						do ni = 0, Omega, 1
							do pi = 0, Omega, 1
								do qi = 0, Omega, 1
									if (ki + li + mi + ni + pi + qi == om) then
										!if (ki + li + mi + ni + pi + qi <= Omega) then
										!if (ki>li) cycle
										!if (ki==li .and. qi>pi) cycle

	!									if (om > 3 .and. qi > 0) cycle  ! Restrict r23 to max of 1
	!									if (om > 3 .and. pi > 0) cycle  ! Restrict r13 to max of 3
	!									if (om > 2 .and. ni > 0) cycle  ! Restrict r3 to max of 0
	!									if (ki >= li .and. qi > pi) cycle  ! Check if r1>r2 and r23 > r13 (powers)

										NumTerm = NumTerm + 1
										PowerTable(NumTerm,1) = ki
										PowerTable(NumTerm,2) = li
										PowerTable(NumTerm,3) = mi
										PowerTable(NumTerm,4) = ni
										PowerTable(NumTerm,5) = pi
										PowerTable(NumTerm,6) = qi

										write (*,*) ki, li, mi, ni, pi, qi!, ki + li + mi + ni + pi + qi
									endif
								enddo
							enddo
						enddo
					enddo
				enddo
			enddo
		enddo

	else  ! Use Peter Van Reeth's ordering instead.
		! I pulled this (modified) snippet from Peter Van Reeth's code so that
		!  my indices match up with his to debug mine easier.
		MEGA=OMEGA
			IHDPP1 = MEGA +1
			INX=0
			DO 65 I=1,IHDPP1
			  DO 66 I23P1=1,I,1
				I23=I23P1 -1
				I12P1M = I-I23
				DO 67 I12P1=1,I12P1M
				  I12=I12P1-1
				  I2P1M =I12P1M -I12
				  DO 68 I2P1 =1,I2P1M
					 I2 = I2P1-1
					 I13P1M = I2P1M-I2
					 DO 69 I13P1=1,I13P1M
						I13 = I13P1 -1
						I3P1M = I13P1M -I13
						DO 70 I3P1 = 1, I3P1M
						   I3=I3P1-1
						   I1 = I3P1M -I3P1

						   !if (I1>I2) cycle
						   !if (I1==I2 .and. I23>I13) cycle

						   INX =INX +1
						   PowerTable(INX,1) = I1
						   PowerTable(INX,2) = I2
						   PowerTable(INX,3) = I12
						   PowerTable(INX,4) = I3
						   PowerTable(INX,5) = I13
						   PowerTable(INX,6) = I23

						   !write (*,*) I1, I2, I12, I3, I13, I23

	70                  CONTINUE
	69                CONTINUE
	68              CONTINUE
	67            CONTINUE
	66          CONTINUE
	65        CONTINUE
		NumTerm = INX
	endif

! REMOVE THIS !
	if (Ordering == 2) then  ! Use my ordering
		NumTerm = 0
		do om = 0, Omega, 1
			do qi = 0, Omega, 1
				do pi = 0, Omega, 1
					do ni = 0, Omega, 1
						do mi = 0, Omega, 1
							do li = 0, Omega, 1
								do ki = 0, Omega, 1
									if (ki + li + mi + ni + pi + qi == om) then
										!if (ki + li + mi + ni + pi + qi <= Omega) then
										!if (ki>li) cycle
										!if (ki==li .and. qi>pi) cycle

	!									if (om > 3 .and. qi > 0) cycle  ! Restrict r23 to max of 1
	!									if (om > 3 .and. pi > 0) cycle  ! Restrict r13 to max of 3
	!									if (om > 2 .and. ni > 0) cycle  ! Restrict r3 to max of 0
	!									if (ki >= li .and. qi > pi) cycle  ! Check if r1>r2 and r23 > r13 (powers)

										NumTerm = NumTerm + 1
										PowerTable(NumTerm,1) = ki
										PowerTable(NumTerm,2) = li
										PowerTable(NumTerm,3) = ni
										PowerTable(NumTerm,4) = mi
										PowerTable(NumTerm,5) = qi
										PowerTable(NumTerm,6) = pi

										write (*,*) ki, li, ni, mi, qi, pi!, ki + li + mi + ni + pi + qi
									endif
								enddo
							enddo
						enddo
					enddo
				enddo
			enddo
		enddo
	endif

	do i = 1, NumTerm, 1
		! Increase r1 by l1 and r2 by l2/l3
		PowerTable(i,1) = PowerTable(i,1) + l1
		PowerTable(i,2) = PowerTable(i,2) + l2
		write (*,'(i3,a,6i2)') i, ":", PowerTable(i,1), PowerTable(i,2), PowerTable(i,3), PowerTable(i,4), PowerTable(i,5), PowerTable(i,6)
	end do

	return
end

subroutine GenCoeffTable(CoeffTable, PowerTablei, i, PowerTablej, j, NumTerms, Alphai, Alphaj, Betai, Betaj, &
						 Gammai, Gammaj, l1r, l2r, l3r)
	implicit none
	real*16, dimension(34) :: CoeffTable
	integer i, j, NumTerms
	integer, dimension(NumTerms,6) :: PowerTablei
	integer, dimension(NumTerms,6) :: PowerTablej
	real*16 Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj
	integer kj, lj, mj, nj, pj, qj, l1r, l2r, l3r

	! We do not really have to do this, but it makes reading the assignments later
	!  easier to follow instead of assigning index numbers to each of k, l, m, etc.
	! In the power tables, we have the following indices:
	!  k = 1, l = 2, m = 3, n = 4, p = 5, q = 6
	kj = PowerTablej(j,1)
	lj = PowerTablej(j,2)
	mj = PowerTablej(j,3)
	nj = PowerTablej(j,4)
	pj = PowerTablej(j,5)
	qj = PowerTablej(j,6)

	CoeffTable(1) = -Alphaj*Alphaj - Betaj*Betaj - Gammaj*Gammaj
	CoeffTable(2) = -kj - kj*kj - kj*mj - kj*pj + l1r + l1r*l1r
	CoeffTable(3) = -2.0q0*mj - kj*mj - 2.0q0*mj*mj - mj*lj - mj*qj - mj*pj
	CoeffTable(4) = -2.0q0
	CoeffTable(5) = -lj - mj*lj - lj*lj - lj*qj + l2r + l2r*l2r
	CoeffTable(6) = mj*lj
	CoeffTable(7) = kj*mj
	CoeffTable(8) = -2.0q0*qj - mj*qj - lj*qj - 2.0q0*qj*qj - qj*nj - qj*pj
	CoeffTable(9) = 2.0q0
	CoeffTable(10) = -nj - qj*nj - nj*nj - nj*pj + l3r + l3r*l3r
	CoeffTable(11) = qj*nj
	CoeffTable(12) = lj*qj
	CoeffTable(13) = -2.0q0*pj - kj*pj - mj*pj - qj*pj - nj*pj - 2.0q0*pj*pj
	CoeffTable(14) = qj*pj
	CoeffTable(15) = mj*pj
	CoeffTable(16) = nj*pj
	CoeffTable(17) = kj*pj
	CoeffTable(18) = -2.0q0
	CoeffTable(19) = mj*qj
	CoeffTable(20) = mj*Alphaj
	CoeffTable(21) = -mj*Alphaj
	CoeffTable(22) = pj*Alphaj
	CoeffTable(23) = -pj*Alphaj
	CoeffTable(24) = 2.0q0 + 2.0q0*Alphaj + 2.0q0*kj*Alphaj + mj*Alphaj + pj*Alphaj
	CoeffTable(25) = -mj*Betaj
	CoeffTable(26) = mj*Betaj
	CoeffTable(27) = qj*Betaj
	CoeffTable(28) = -qj*Betaj
	CoeffTable(29) = -2.0q0 + 2.0q0*Betaj + mj*Betaj + 2.0q0*lj*Betaj + qj*Betaj
	CoeffTable(30) = -qj*Gammaj
	CoeffTable(31) = qj*Gammaj
	CoeffTable(32) = -pj*Gammaj
	CoeffTable(33) = pj*Gammaj
	CoeffTable(34) = -2.0q0 + 2.0q0*Gammaj + qj*Gammaj + 2.0q0*nj*Gammaj + pj*Gammaj

	return
end

! Note that the naming is a little different here.  I used rPowerTable here as the parameter name but
!  use rPowers elsewhere.
subroutine GenRPowerTable(rPowerTable, PowerTablei, i, PowerTablej, j, NumTerms)
	integer, dimension(34,6) :: rPowerTable
	integer, dimension(NumTerms,6) :: PowerTablei
	integer, dimension(NumTerms,6) :: PowerTablej
	integer i, j, NumTerms
	integer ki, li, mi, ni, pi, qi, kj, lj, mj, nj, pj, qj
	integer, dimension(34,6) :: rPowers
	integer n

	! This is a 2-dimensional array expressed in a contiguous 1-D array.  I see no way to assign a 2-D
	!  array in Fortran (at least in G95).  I found several examples that would not compile with G95.
	!  These are taken directly from the table in rpowers.pdf.  Each power is covered by 2 lines, since
	!  there are 34 terms to take care of.  These can be read as going down the columns of rpowers.pdf.
	data rPowers / 0,-2, 0, 0, 0, 2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 1,-1, 1,-1,-1, 2, 0, 0, 0, 0, 0, 0, 2, 0, 0, &  ! r1
				   0, 0, 0, 0,-2,-2, 2, 0, 0, 0, 2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0,-1, 1, 1,-1,-1, 2, 0, 0, 0, 0, &  ! r2
				   0, 0,-2,-1, 0,-2,-2, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 0,-2,-2,-2, 0, 0, 0,-2,-2, 0, 0, 0, 0, 0, 0, 0, 0, &  ! r12
				   0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-2, 2, 0, 0, 0,-2, 2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, 0,-1, 1,-1, 1,-1, &  ! r3
				   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-2,-2,-2,-2,-1, 2, 0, 0,-2,-2, 0, 0, 0, 0, 0, 0, 0, 0,-2,-2, 0, &  ! r31
				   0, 0, 0, 0, 0, 0, 0,-2,-1, 0,-2,-2, 0,-2, 2, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0,-2,-2, 0,-2,-2, 0, 0, 0 /   ! r23
				  !1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34

	! We do not really have to do this, but it makes reading the assignments later
	!  easier to follow instead of assigning index numbers to each of k, l, m, etc.
	! In the power tables, we have the following indices:
	!  k = 1, l = 2, m = 3, n = 4, p = 5, q = 6
	ki = PowerTablei(i,1)
	li = PowerTablei(i,2)
	mi = PowerTablei(i,3)
	ni = PowerTablei(i,4)
	pi = PowerTablei(i,5)
	qi = PowerTablei(i,6)
	kj = PowerTablej(j,1)
	lj = PowerTablej(j,2)
	mj = PowerTablej(j,3)
	nj = PowerTablej(j,4)
	pj = PowerTablej(j,5)
	qj = PowerTablej(j,6)

	! Combine powers of like r's from f_i, f_j and the powers in rpowers.pdf.
	do n = 1, 34, 1
		rPowerTable(n,1) = ki + kj + rPowers(n,1)
		rPowerTable(n,2) = li + lj + rPowers(n,2)
		rPowerTable(n,3) = mi + mj + rPowers(n,3)
		rPowerTable(n,4) = ni + nj + rPowers(n,4)
		rPowerTable(n,5) = pi + pj + rPowers(n,5)
		rPowerTable(n,6) = qi + qj + rPowers(n,6)
	enddo

	return
end

subroutine GenCoeffTableSH(CoeffTable, PowerTablei, i, PowerTablej, j, NumTerms, Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, l1r, l2r, l3r)
	implicit none
	real*16, dimension(6) :: CoeffTable
	integer i, j, NumTerms
	integer, dimension(NumTerms,6) :: PowerTablei
	integer, dimension(NumTerms,6) :: PowerTablej
	real*16 Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj
	integer kj, lj, mj, nj, pj, qj, l1r, l2r, l3r

	kj = PowerTablej(j,1)
	lj = PowerTablej(j,2)
	mj = PowerTablej(j,3)
	nj = PowerTablej(j,4)
	pj = PowerTablej(j,5)
	qj = PowerTablej(j,6)

	CoeffTable(1) = mj
	CoeffTable(2) = pj
	CoeffTable(3) = qj
	CoeffTable(4) = mj
	CoeffTable(5) = pj
	CoeffTable(6) = qj

	return
end

! Note that the naming is a little different here.  I used rPowerTable here as the parameter name but
!  use rPowers elsewhere.
subroutine GenRPowerTableSH(rPowerTable, PowerTablei, i, PowerTablej, j, NumTerms)
	integer, dimension(6,6) :: rPowerTable
	integer, dimension(NumTerms,6) :: PowerTablei
	integer, dimension(NumTerms,6) :: PowerTablej
	integer i, j, NumTerms
	integer ki, li, mi, ni, pi, qi, kj, lj, mj, nj, pj, qj
	integer, dimension(6,6) :: rPowers
	integer n

	data rPowers / -1,-1, 0, 1, 1, 0, &  ! r1
				    1, 0,-1,-1, 0, 1, &  ! r2
				   -2, 0, 0,-2, 0, 0, &  ! r12
				    0, 1, 1, 0,-1,-1, &  ! r3
				    0,-2, 0, 0,-2, 0, &  ! r31
				    0, 0,-2, 0, 0,-2 /   ! r23
				   !1, 2, 3, 4, 5, 6

	! In the power tables, we have the following indices:
	!  k = 1, l = 2, m = 3, n = 4, p = 5, q = 6
	ki = PowerTablei(i,1)
	li = PowerTablei(i,2)
	mi = PowerTablei(i,3)
	ni = PowerTablei(i,4)
	pi = PowerTablei(i,5)
	qi = PowerTablei(i,6)
	kj = PowerTablej(j,1)
	lj = PowerTablej(j,2)
	mj = PowerTablej(j,3)
	nj = PowerTablej(j,4)
	pj = PowerTablej(j,5)
	qj = PowerTablej(j,6)

	! Combine powers of like r's from f_i, f_j and the powers in rpowers.pdf.
	do n = 1, 6, 1
		rPowerTable(n,1) = ki + kj + rPowers(n,1)
		rPowerTable(n,2) = li + lj + rPowers(n,2)
		rPowerTable(n,3) = mi + mj + rPowers(n,3)
		rPowerTable(n,4) = ni + nj + rPowers(n,4)
		rPowerTable(n,5) = pi + pj + rPowers(n,5)
		rPowerTable(n,6) = qi + qj + rPowers(n,6)
	enddo

	return
end

! Sets all WMatrix elements equal to 0.
! TODO: Is there an equivalent to the C++ memset?
subroutine ClearWMatrix(WMatrix)
	use WLimits
	implicit none
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	integer l, m, n

	do l = lmin, lmax, 1
		do m = mmin, mmax, 1
			do n = nmin, nmax, 1
				WMatrix(l, m, n, 1) = 0.0q0
				WMatrix(l, m, n, 2) = 0.0q0
				WMatrix(l, m, n, 3) = 0.0q0
				WMatrix(l, m, n, 4) = 0.0q0
				WMatrix(l, m, n, 5) = 0.0q0
				WMatrix(l, m, n, 6) = 0.0q0
			end do
		end do
	end do

	return
end

! This precalculates the W matrices, since the W function is computationally expensive.
subroutine CalcWMatrices(Omega, WMatrix, Alpha, Beta, Gamma, pmax)
	use WLimits
	implicit none
	integer Omega
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	real*16 Alpha, Beta, Gamma
	integer pmax
	real*16 W
	integer l, m, n, k

	!$omp parallel do shared(lmin,lmax,mmin,mmax,nmin,nmax,pmax,Alpha,Beta,Gamma,WMatrix) private(m,n) schedule(dynamic,5)
	do l = lmin, lmax, 1
		write (*,*) "wmatrix l:", l, "/", lmax
		!write (*,"(a)",advance='no') '.'
		do m = mmin, mmax, 1
			do n = nmin, nmax, 1
				!if (l + m + n + 2 >= 0 .and. l + m + 1 >= 0) then  ! TODO: Needed?
					do k = 1, 6, 1
						! Note that the ordering of alpha, beta and gamma is the same as the ordering
						!  in the terms of equation (6) of Drake/Yan '95.
						if (WMatrix(l, m, n, k) /= 0.0q0) then
							select case(k)
								case (1)
									WMatrix(l, m, n, 1) = W(l, m, n, Alpha, Beta, Gamma, pmax)
								case (2)
									WMatrix(l, m, n, 2) = W(l, m, n, Alpha, Gamma, Beta, pmax)
								case (3)
									WMatrix(l, m, n, 3) = W(l, m, n, Beta, Alpha, Gamma, pmax)
								case (4)
									WMatrix(l, m, n, 4) = W(l, m, n, Beta, Gamma, Alpha, pmax)
								case (5)
									WMatrix(l, m, n, 5) = W(l, m, n, Gamma, Alpha, Beta, pmax)
								case (6)
									WMatrix(l, m, n, 6) = W(l, m, n, Gamma, Beta, Alpha, pmax)
							end select  ! There is no need for a default case.
						end if
					end do
				!end if
			end do
		end do
	end do
	write (*,*)

	return
end

subroutine CalcMatricesSub(RunCalc, UsePreCalc, CalcSH, PowerTablei, PowerTablej, WMatrix, PhiPhi, Phi2HPhi, NumTerms, OffI, OffJ, Alphai, Alphaj, Betai, Betaj, &
							Gammai, Gammaj, l1l, l2l, l3l, m1l, m2l, m3l, l1r, l2r, l3r, m1r, m2r, m3r, M12max, M23max, M31max, pmax, IsTriplet, Method)
	use WLimits
	implicit none
	real*16, dimension(34) :: CoeffTable
	real*16, dimension(6) :: CoeffTableSH
	integer, dimension(34,6) :: rPowers
	integer, dimension(6,6) :: rPowersSH
	integer, dimension(6) :: sldata, srdata
	integer, dimension(NumTerms,6) :: PowerTablei, PowerTablej
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	real*16, dimension(NumTerms*2,NumTerms*2) :: PhiPhi, Phi2HPhi
	integer M12max, M23max, M31max, pmax, NumTerms, OffI, OffJ, Method
	logical RunCalc, UsePreCalc, CalcSH
	integer l1l, l2l, l3l, m1l, m2l, m3l, l1r, l2r, l3r, m1r, m2r, m3r
	real*16 Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj
	real*16 HylleraasIntegral, HylleraasIntegralGeneral, CP12Angular
	real*16 Sum, SumPiHalf
	real*16 PI
	integer i, j, n, IsTriplet
	real*16 RemoveMe, SHPart, SHPartPiHalf
	real*16 PiHalf
	data sldata / 2, 3, 3, 1, 1, 2 /
	data srdata / 1, 1, 2, 2, 3, 3 /

	! 1/(2pi) calculated in Mathematica
	PiHalf = 0.1591549430918953357688837633725143620345_16

	!call omp_set_num_threads(1)

	!$omp parallel do shared(NumTerms) private(j,Sum,SHPart,RemoveMe,CoeffTable,CoeffTableSH,rPowers,rPowersSH) schedule(dynamic,10)
	do i = 1, NumTerms, 1
		write (*,*) i
		!write (*,"(i7)",advance='no') i
		!do j = 1, i, 1
		do j = 1, NumTerms, 1
			Sum = 0.0q0
			call GenCoeffTable(CoeffTable, PowerTablei, i, PowerTablej, j, NumTerms, &
								Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, l1r, l2r, l3r)
			call GenRPowerTable(rPowers, PowerTablei, i, PowerTablej, j, NumTerms)
			call GenCoeffTableSH(CoeffTableSH, PowerTablei, i, PowerTablej, j, NumTerms, &
								Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, l1r, l2r, l3r)
			call GenRPowerTableSH(rPowersSH, PowerTablei, i, PowerTablej, j, NumTerms)

			do n = 1, 34, 1
            !do n = 4, 4, 1
				if (CoeffTable(n) /= 0.0q0) then
					! Note that the order of the parameters to the HylleraasIntegral function looks strange. This is
					!  because the Drake and Yan paper (1995) expressed the integrand in the following order:
					!  r1 r2 r3 r12 r23 r31, and the Armour and Humberston article has them in this order:
					!  r1 r2 r12 r3 r13 r23 (equation 3.14). So we have to swap the third and fourth parameters, along
					!  with the fifth and sixth.

					! Do the PhiPhi inner product
					RemoveMe = HylleraasIntegralGeneral(RunCalc, UsePreCalc, rPowers(n,1), rPowers(n,2), rPowers(n,4), rPowers(n,3), rPowers(n,6), &
												  rPowers(n,5), Alphai+Alphaj, Betai+Betaj, Gammai+Gammaj, &
												  l1l, l2l, l3l, m1l, m2l, m3l, l1r, l2r, l3r, m1r, m2r, m3r, M12max, M23max, M31max, pmax, 0, 0, 0, WMatrix, Method)
					Sum = Sum + RemoveMe * CoeffTable(n)
				end if
			enddo

			! TODO: Check for whether these terms should be 0 before calculating.
			! Now we need to take care of the terms that act on the spherical harmonics. There are 6 terms total from this.
			if (CalcSH == .true.) then
				SHPart = 0.0q0
				do n = 1, 6, 1
					if (CoeffTableSH(n) /= 0.0q0) then
						RemoveMe = HylleraasIntegralGeneral(RunCalc, UsePreCalc, rPowersSH(n,1), rPowersSH(n,2), rPowersSH(n,4), rPowersSH(n,3), rPowersSH(n,6), &
															  rPowersSH(n,5), Alphai+Alphaj, Betai+Betaj, Gammai+Gammaj, &
															  l1l, l2l, l3l, m1l, m2l, m3l, l1r, l2r, l3r, m1r, m2r, m3r, M12max, M23max, M31max, pmax, n, sldata(n), srdata(n), WMatrix, Method)
						SHPart = SHPart + RemoveMe * CoeffTableSH(n)
					end if
				end do
				!SumPiHalf = Sum * PiHalf  ! TODO: Remove this.
				!SHPartPiHalf = SHPart * PiHalf  ! TODO: Remove this.
				Sum = Sum + SHPart * 2  ! The other terms have a 1/2 in front, and we are calculating 2H
			end if

			if (IsTriplet == 0) then
				Phi2HPhi(i+OffI,j+OffJ) = Phi2HPhi(i+OffI,j+OffJ) + Sum * PiHalf
			else
				Phi2HPhi(i+OffI,j+OffJ) = Phi2HPhi(i+OffI,j+OffJ) - Sum * PiHalf
			end if

			! Do the PhiPhi inner product
			RemoveMe = HylleraasIntegralGeneral(RunCalc, UsePreCalc, PowerTablei(i,1)+PowerTablej(j,1), PowerTablei(i,2)+PowerTablej(j,2), &
						PowerTablei(i,4)+PowerTablej(j,4), PowerTablei(i,3)+PowerTablej(j,3), &
						PowerTablei(i,6)+PowerTablej(j,6), PowerTablei(i,5)+PowerTablej(j,5), Alphai+Alphaj, Betai+Betaj, Gammai+Gammaj, &
						l1l, l2l, l3l, m1l, m2l, m3l, l1r, l2r, l3r, m1r, m2r, m3r, M12max, M23max, M31max, pmax, 0, 0, 0, WMatrix, Method)
			if (IsTriplet == 0) then
				PhiPhi(i+OffI,j+OffJ) = PhiPhi(i+OffI,j+OffJ) + RemoveMe * PiHalf
			else
				PhiPhi(i+OffI,j+OffJ) = PhiPhi(i+OffI,j+OffJ) - RemoveMe * PiHalf
			endif
		enddo
	enddo

	write (*,*)
	return
end

subroutine CalcMatrices(RunCalc, UsePreCalc, PowerTabler1i, PowerTabler1j, PowerTabler2i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms, &
						Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, LValue, M12max, M23max, M31max, pmax, IsTriplet, Method, Exchanged)
	use WLimits
	implicit none
	integer, dimension(NumTerms/2,6) :: PowerTabler1i, PowerTabler1j, PowerTabler2i, PowerTabler2j
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	real*16, dimension(NumTerms,NumTerms) :: PhiPhi, Phi2HPhi
	integer NumTerms, LValue, M12max, M23max, M31max, pmax, IsTriplet, Method
	logical RunCalc, UsePreCalc
	real*16 Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj
	logical Exchanged

	! 1-1 matrix elements
	write (*,*) "Calculating 1-1 matrix elements"
	call CalcMatricesSub(RunCalc, UsePreCalc, .false., PowerTabler1i, PowerTabler1j, WMatrix, PhiPhi, Phi2HPhi, NumTerms/2, 0, 0, Alphai, Alphaj, Betai, Betaj, &
						Gammai, Gammaj, LValue, 0, 0, 0, 0, 0, LValue, 0, 0, 0, 0, 0, M12max, M23max, M31max, pmax, IsTriplet, Method)

    if (LValue == 0) then  ! S-wave only has one symmetry
        return
    end if

	! 2-2 matrix elements
	write (*,*) "Calculating 2-2 matrix elements"
	if (Exchanged == .true.) then  ! Swap l2r and l3r
		call CalcMatricesSub(RunCalc, UsePreCalc, .true., PowerTabler2i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms/2, NumTerms/2, NumTerms/2, Alphai, Alphaj, Betai, Betaj, &
							Gammai, Gammaj, 0, LValue, 0, 0, 0, 0, 0, 0, LValue, 0, 0, 0, M12max, M23max, M31max, pmax, IsTriplet, Method)
	else
		call CalcMatricesSub(RunCalc, UsePreCalc, .false., PowerTabler2i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms/2, NumTerms/2, NumTerms/2, Alphai, Alphaj, Betai, Betaj, &
							Gammai, Gammaj, 0, LValue, 0, 0, 0, 0, 0, LValue, 0, 0, 0, 0, M12max, M23max, M31max, pmax, IsTriplet, Method)
	end if

	! 1-2 matrix elements
	write (*,*) "Calculating 1-2 matrix elements"
	if (Exchanged == .true.) then  ! Swap l2r and l3r
		call CalcMatricesSub(RunCalc, UsePreCalc, .true., PowerTabler1i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms/2, 0, NumTerms/2, Alphai, Alphaj, Betai, Betaj, &
							Gammai, Gammaj, LValue, 0, 0, 0, 0, 0, 0, 0, LValue, 0, 0, 0, M12max, M23max, M31max, pmax, IsTriplet, Method)
	else
		call CalcMatricesSub(RunCalc, UsePreCalc, .true.,  PowerTabler1i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms/2, 0, NumTerms/2, Alphai, Alphaj, Betai, Betaj, &
							Gammai, Gammaj, LValue, 0, 0, 0, 0, 0, 0, LValue, 0, 0, 0, 0, M12max, M23max, M31max, pmax, IsTriplet, Method)
	end if

	! 2-1 matrix elements
	write (*,*) "Calculating 2-1 matrix elements"
	call CalcMatricesSub(RunCalc, UsePreCalc, .true., PowerTabler2i, PowerTabler1j, WMatrix, PhiPhi, Phi2HPhi, NumTerms/2, NumTerms/2, 0, Alphai, Alphaj, Betai, Betaj, &
						Gammai, Gammaj, 0, LValue, 0, 0, 0, 0, LValue, 0, 0, 0, 0, 0, M12max, M23max, M31max, pmax, IsTriplet, Method)

	return
end

!real*16 function ederivwrapper(Omega, NumTerms, M12max, pmax, IsTriplet, Ordering, Method, EigenRoutine, Alpha, Beta, Gamma, Iter, Energy)
!	implicit none
!	real*16, allocatable, dimension(:,:) :: PhiPhi, Phi2HPhi
!	real*16, allocatable, dimension(:,:) :: PhiPhi8, Phi2HPhi8
!	real*16, allocatable, dimension(:) :: Energies, Workspace
!	integer Omega, NumTerms, M12max, pmax, IsTriplet, Ordering, Method, EigenRoutine, Info, Iter
!	real*16 Alpha, Beta, Gamma, Energy
!	real*16 EDeriv
!
!	allocate(PhiPhi(NumTerms,NumTerms))
!	allocate(Phi2HPhi(NumTerms,NumTerms))
!	allocate(Energies(NumTerms))
!	allocate(Workspace(3*NumTerms-1))  ! Not really needed for Newdsygv?
!
!	Energies = 0.0q0
!
!	Energy = EDeriv(Omega, NumTerms, Alpha, Beta, Gamma, 1, PhiPhi, Phi2HPhi, PhiPhi8, Phi2HPhi8, &
!					M12max, pmax, 0, IsTriplet, Ordering, Method, EigenRoutine)
!
!	Phi2HPhi = Phi2HPhi / 2.0q0  ! TODO: Remove?
!	if (EigenRoutine == 1) then
!		allocate(PhiPhi8(NumTerms,NumTerms))
!		allocate(Phi2HPhi8(NumTerms,NumTerms))
!		PhiPhi8 = PhiPhi
!		Phi2HPhi8 = Phi2HPhi
!		call dsygv(1, 'N', 'L', NumTerms, Phi2HPhi8, NumTerms, PhiPhi8, NumTerms, Energies, Workspace, 3*NumTerms-1, Info)
!		! TODO: Test Info!
!		write (*,*) "Info: ", Info
!		deallocate(PhiPhi8, Phi2HPhi8)
!	else  ! EigenRoutine == 2
!		call Newdsygv(1, 'N', 'L', NumTerms, Phi2HPhi, NumTerms, PhiPhi, NumTerms, Energies, Workspace, 3*NumTerms-1, Info)
!	end if
!
!	Energy = Energies(1)
!
!	write (*,"(A,3F8.5)") "Alpha, Beta, Gamma: ", Alpha, Beta, Gamma
!	write (10,"(I4,A,3F8.5)") Iter, "; Alpha, Beta, Gamma: ", Alpha, Beta, Gamma  ! I dislike hardcoding the 10, but it's easier at this point.
!	write (10,"(A,F16.12)") "Energy: ", Energy
!	write (10,*)
!	flush(10)
!
!	deallocate(PhiPhi, Phi2HPhi, Energies, Workspace)
!	ederivwrapper = 1.0q0
!end

! Calculates the derivative of the energy function.  If the Deriv parameter = 0, then it exits early with
!  PhiPhi and Phi2HPhi filled.
real*16 function EDeriv(Omega, NumTerms, Alpha, Beta, Gamma, EigenNum, PhiPhi, Phi2HPhi, &
						M12max, M23max, M31max, pmax, Deriv, IsTriplet, Ordering, Method, EigenRoutine, LValue)
	use WLimits
	!use nag_nsym_gen_eig
	implicit none
	real*16 Alpha, Beta, Gamma, Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, e
	integer, allocatable, dimension(:,:) :: PowerTabler1i, PowerTabler1j, PowerTabler2i, PowerTabler2j  ! This contains the powers of the Hylleraas terms.
	integer CalcPowerTableSize, PreCalcGammaSize  ! Function definitions
	integer EigenNum  ! This is the energy eigenvalue number we are dealing with.
	integer Omega, NumTerms, M12max, M23max, M31max, pmax, Deriv, IsTriplet, Method, Ordering, i, j, n, TempJ, Info, EigenRoutine, LValue
	real*16, dimension(NumTerms,NumTerms) :: PhiPhi, Phi2HPhi
	real*16, allocatable, dimension(:,:,:,:) :: WMatrix
	real*16 PhiHPhiSum, PhiPhiSum, Norm
	integer l, m, k
	logical UsePreCalc

	UsePreCalc = .true.
	!UsePreCalc = .false.

	allocate(PowerTabler1i(NumTerms/2, 6))
	call GenOmegaPowerTable(Omega, PowerTabler1i, NumTerms/2, Ordering, LValue, 0)
	allocate(PowerTabler1j(NumTerms/2, 6))
	call GenOmegaPowerTable(Omega, PowerTabler1j, NumTerms/2, Ordering, LValue, 0)
	allocate(PowerTabler2i(NumTerms/2, 6))
	call GenOmegaPowerTable(Omega, PowerTabler2i, NumTerms/2, Ordering, 0, LValue)
	allocate(PowerTabler2j(NumTerms/2, 6))
	call GenOmegaPowerTable(Omega, PowerTabler2j, NumTerms/2, Ordering, 0, LValue)

	! Set this matrix equal to 0 because of the Phi2HPhi(i,j) = Phi2HPhi(i,j) + Sum line in CalcMatrices
	!  (and equivalent for PhiPhi).  This allows us to use the same subroutine for the direct and exchange elements.
	Phi2HPhi = 0.0_16
	PhiPhi = 0.0_16

	! For the direct integration, f_i and f_j have beta and gamma in the same place.
	Alphai = Alpha; Alphaj = Alpha; Betai = Beta; Betaj = Beta; Gammai = Gamma; Gammaj = Gamma;

	! Precalculate the W matrices.  lmin, lmax, etc. are the upper and lower limits for each of the three
	!  parameters to the W function (in HylleraasIntegral.f90).  These limits were determined by me, and
	!  there is a document detailing these limits (W Function Limits.pdf).
	!!lmin = 1;  lmax = 2*(Omega+LValue) + 4*max(linf,minf) + 4;
	!!mmin = -1 - 3*max(linf,minf);  mmax = 2*(Omega+LValue) + 3*max(linf,minf) + 3;
	!!nmin = -2 - 4*max(linf,minf);  nmax = 2*(Omega+LValue) + 2;
	lmin = 1;  lmax = min(M12max, min(M23max, M31max))*2 + LValue*2 + Omega*2 + 5;
	mmin = -1;  mmax = 2*(LValue+Omega) + 3;
	nmin = -(min(M12max, min(M23max, M31max))*3 + 2*Omega);  nmax = 2*(Omega+LValue) + 2;
	allocate(WMatrix(lmin:lmax, mmin:mmax, nmin:nmax, 6))

    call GenFactorial(400)

	write (*,*)
	write (*,*) "Starting calculation of direct-direct terms"
	if (UsePreCalc == .true.) then
		write (*,*) "Precomputing direct-direct W matrix"
		call ClearWMatrix(WMatrix)
		! First call it with RunCalc = false to determine what W functions to calculate.
		call CalcMatrices(.false., .true., PowerTabler1i, PowerTabler1j, PowerTabler2i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms, &
							Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, LValue, M12max, M23max, M31max, pmax, IsTriplet, Method, .false.)
		! Then precalculate all W functions that are used.
		call CalcWMatrices(Omega, WMatrix, Alphai+Alphaj, Betai+Betaj, Gammai+Gammaj, pmax)
		write (*,*) "Finished precomputing direct-direct W matrix"
	end if
	! This subroutine calculates the PhiPhi and Phi2HPhi matrices for the direct integrals.
	call CalcMatrices(.true., UsePreCalc, PowerTabler1i, PowerTabler1j, PowerTabler2i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms, &
						Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, LValue, M12max, M23max, M31max, pmax, IsTriplet, Method, .false.)
	if (IsTriplet == 1) then  ! Only do this for the triplet case.
		PhiPhi = -PhiPhi
		Phi2HPhi = -Phi2HPhi
    endif

	!goto 300  ! Skip permutation for testing

	! Now we have to do the same thing for the exchange operator, P_23.  We operate it on f_j by switching the
	!  2<->3 powers in PowerTablej and recalculating, along with beta and gamma.
	do n = 1, NumTerms/2, 1
		! This exchanges r2 and r3.
		TempJ = PowerTabler1j(n,2)
		PowerTabler1j(n,2) = PowerTabler1j(n,4)  ! l with n
		PowerTabler1j(n,4) = TempJ
		TempJ = PowerTabler2j(n,2)
		PowerTabler2j(n,2) = PowerTabler2j(n,4)  ! l with n
		PowerTabler2j(n,4) = TempJ
		! This exchanges r12 and r13 (r31).
		TempJ = PowerTabler1j(n,3)
		PowerTabler1j(n,3) = PowerTabler1j(n,5)  ! m with p
		PowerTabler1j(n,5) = TempJ
		TempJ = PowerTabler2j(n,3)
		PowerTabler2j(n,3) = PowerTabler2j(n,5)  ! m with p
		PowerTabler2j(n,5) = TempJ
	enddo
	! Swap beta and gamma for f_j.
	Alphai = Alpha; Alphaj = Alpha; Betaj = Gamma; Betai = Beta; Gammaj = Beta; Gammai = Gamma;

	!i = 0
	!do l = lmin, lmax, 1
	!	do m = mmin, mmax, 1
	!		do n = nmin, nmax, 1
	!			do k = 1, 6, 1
	!				if (WMatrix(l, m, n, k) == 1000.0q0) i = i + 1
	!			end do
	!		end do
	!	end do
	!end do
	!
	!write (*,*) "Total WMatrix used: ", i
	!write (*,*) "Total WMatrix size: ", (lmax-lmin+1) * (mmax-mmin+1) * (nmax-nmin+1) * 6
	!stop

	! We have to recalculate the W matrices again, since we had the swaps.
	write (*,*) "Starting calculation of direct-exchange terms"
	if (UsePreCalc == .true.) then
		write (*,*) "Precomputing direct-exchange W matrix"
		call ClearWMatrix(WMatrix)
		! The W functions to calculate are not, in general, the same as that for the direct-direct case.
		call CalcMatrices(.false., UsePreCalc, PowerTabler1i, PowerTabler1j, PowerTabler2i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms, &
						Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, LValue, M12max, M23max, M31max, pmax, IsTriplet, Method, .true.)
		call CalcWMatrices(Omega, WMatrix, Alphai+Alphaj, Betai+Betaj, Gammai+Gammaj, pmax)
		write (*,*) "Finished precomputing direct-exchange W matrix"
	end if
	! Calculate the matrix elements for the exchanged terms, and add them to the direct terms.
	call CalcMatrices(.true., UsePreCalc, PowerTabler1i, PowerTabler1j, PowerTabler2i, PowerTabler2j, WMatrix, PhiPhi, Phi2HPhi, NumTerms, &
						Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, LValue, M12max, M23max, M31max, pmax, IsTriplet, Method, .true.)

	! If we are not optimizing the nonlinear parameters, return since matrices have been calculated.
300	EDeriv = 1.0q0  ! Random value, return not used in this case.

	! Clean up memory before exiting
	deallocate(WMatrix)
	deallocate(PowerTabler1i)
	deallocate(PowerTabler1j)
	deallocate(PowerTabler2i)
	deallocate(PowerTabler2j)

	return
end


! =====================================================
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)
! =====================================================
    implicit double precision (a-h,o-z)

!     # Riemann solver in the transverse direction for the shallow water
!     equations .
!     # Split asdq (= A^* \Delta q, where * = + or -)
!     # into down-going flux difference bmasdq (= B^- A^* \Delta q)
!     #    and up-going flux difference bpasdq (= B^+ A^* \Delta q)

    dimension     ql(meqn, 1-mbc:maxm+mbc)
    dimension     qr(meqn, 1-mbc:maxm+mbc)
    dimension   asdq(meqn, 1-mbc:maxm+mbc)
    dimension bmasdq(meqn, 1-mbc:maxm+mbc)
    dimension bpasdq(meqn, 1-mbc:maxm+mbc)

    dimension waveb(3,3),sb(3)

!     # Roe averages quantities of each interface
    parameter (maxm2 = 1800)
    double precision u(-6:maxm2+7),v(-6:maxm2+7),a(-6:maxm2+7), &
                     h(-6:maxm2+7)

    if (ixy == 1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

    do 10 i = 2-mbc, mx+mbc
        h(i) = (qr(1,i-1)+ql(1,i))*0.50d0
        hsqrtl = dsqrt(qr(1,i-1))
        hsqrtr = dsqrt(ql(1,i))
        hsq2 = hsqrtl + hsqrtr
        u(i) = (qr(mu,i-1)/hsqrtl + ql(mu,i)/hsqrtr) / hsq2
        v(i) = (qr(mv,i-1)/hsqrtl + ql(mv,i)/hsqrtr) / hsq2
        a(i) = dsqrt(grav*h(i))
    10 END DO

    do 20 i = 2-mbc, mx+mbc
        a1 = (0.50d0/a(i))*((v(i)+a(i))*asdq(1,i)-asdq(mv,i))
        a2 = asdq(mu,i) - u(i)*asdq(1,i)
        a3 = (0.50d0/a(i))*(-(v(i)-a(i))*asdq(1,i)+asdq(mv,i))

        waveb(1,1) = a1
        waveb(mu,1) = a1*u(i)
        waveb(mv,1) = a1*(v(i)-a(i))
        sb(1) = v(i) - a(i)

        waveb(1,2) = 0.0d0
        waveb(mu,2) = a2
        waveb(mv,2) = 0.0d0
        sb(2) = v(i)

        waveb(1,3) = a3
        waveb(mu,3) = a3*u(i)
        waveb(mv,3) = a3*(v(i)+a(i))
        sb(3) = v(i) + a(i)

    !           # compute the flux differences bmasdq and bpasdq

        do 30 m=1,meqn
            bmasdq(m,i) = 0.d0
            bpasdq(m,i) = 0.d0
            do 30 mw=1,mwaves
                bmasdq(m,i) = bmasdq(m,i) &
                + dmin1(sb(mw), 0.d0) * waveb(m,mw)
                bpasdq(m,i) = bpasdq(m,i) &
                + dmax1(sb(mw), 0.d0) * waveb(m,mw)
        30 END DO

    20 END DO

    return
    end subroutine rpt2


      subroutine othersums(irho)
c--
c     calculates other1
c     of integral of W(lambda) which is not dependant on lambda
c--
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use parambs
      use vmec0
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer :: irho
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec), parameter :: zero = 0, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, m
      real(rprec) :: denom, qn
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(rprec) , EXTERNAL :: sumit
C-----------------------------------------------
c
c-  m - poloidal, n - toroidal
c
      if (isymm0 .ne. 0) then
         other1(irho) = zero
         return
      endif
c
c- Form the "other" sums.  The first uses alpha1(m,n), calculated in WOFLAM,
c  and d(m,n) from DENM.
c
c- Load  rfmn with
c
c  (m*R+n*periods*S)/(m-n*periods*q) *
c         exp(m*thetamax-n*zetahmax) * (1.5*alpha1(m,n)+d(m,n))
c
c- for only those harmonics that are going to be used in the sum.
c
      qn = periods*qsafety(irho)*zetasign
      do m = -mbuse, mbuse
         do n = 0, nbuse
            denom = m + n*qn
            if (n.ne.0 .or. m.ne.0) then
               denom = denom/(denom**2 + (damp_bs*m)**2)
               rfmn(m,n) = (m*capr(irho)+n*periods*caps(irho))*denom*(
     1            cos(m*thetamax(irho)-n*zetahmax(irho))*real(1.5_dp*
     2            alpha1mn(m,n)+dmn(m,n))-sin(m*thetamax(irho)-n*
     3            zetahmax(irho))*aimag(1.5_dp*alpha1mn(m,n)+dmn(m,n)))
            else
               rfmn(m,n) = zero
            endif
         end do
      end do

c  First sum,

      other1(irho) = sumit(rfmn,mbuse,nbuse)
c
c- Then multiply by all the stuff out front.
c
      other1(irho) = -other1(irho)*qsafety(irho)/ftrapped(irho)*(one +
     1   aiogar(irho)/qsafety(irho))

      end subroutine othersums


        FUNCTION Obliquity(T)

c       T is the Julian Date (TDT)

        IMPLICIT REAL*8 (A-Z)

        PI = 3.1415926535897932d0
        RPD = PI/180.d0

        Tu = (T-2451545d0)/36525d0
        O = 23.439291d0 + Tu *
     1  (-.0130042d0 + Tu * (-.00000016d0 + Tu * .000000504d0))

        Obliquity = O * RPD

        RETURN
        END


subroutine courant(iyd,tu,kp,lon,lat,Jsup)

implicit none

integer,parameter :: npt=10000
integer :: iyd,ndeg,mdeg,ierr
real*8 :: tu,lon,lat
real :: kp,Jsup
real*8 :: phicourant(npt),psi
real*8 :: latequi,Lmin,Lmax

save ierr

interface

  subroutine val_fit(lon,lat,ndeg,mdeg,coef_psi,latmin,latmax,latequi,psi,psi_est,psi_nord)
    Integer	::	ndeg,mdeg
    Real*8	::	latmin,latmax,latequi
    Real*8	::	lon,lat,coef_psi(:)
    Real*8	::	psi
    Real*8, optional :: psi_est,psi_nord
  end subroutine val_fit

end interface

	call coef_cour(iyd,tu,kp,ndeg,mdeg,phicourant,	&
      		       Lmin,Lmax,latequi,ierr)
Lmin=0.d0
Lmax=0.d0
!call IMM_COUR(ndeg,mdeg,phicourant,Lmin,Lmax,latequi)

if (Lmin.lt.Lmax) then
  ierr=0
else
  ierr=1
endif

Jsup=0.
if (ierr.eq.0) then
  call val_fit(lon,lat,ndeg,mdeg,phicourant,Lmin,Lmax,latequi,psi)
  Jsup=psi
!	dans le fichier initial le courant est en 10^-7 A/m2
  Jsup=Jsup/10.
endif

return
end subroutine courant


program main
    use sparse_ir
    use sparse_ir_io
    use sparse_ir_preset
    implicit none

    call test_fit()
    call test_under_fitting()
    call test_over_fitting()
    call test_fermion(.true.)
    !call test_boson(.true.)
    !call test_fermion(.false.)
    !call test_boson(.false.)

    contains

    subroutine test_fit()
        complex(kind(0d0)) :: a(2, 2), y(1, 2), x(1, 2), y_reconst(1, 2)
        type(DecomposedMatrix) :: dm
        a(1, 1) = 2.d0
        a(2, 1) = 0.1d0
        a(1, 2) = 0.d0
        a(2, 2) = 1.d0

        dm = decompose(a, 1d-20)

        y(1, 1) = 0.2d0
        y(1, 2) = 0.1d0

        call fit_impl(y, dm, x)

        y_reconst = transpose(matmul(dm%a, transpose(x)))
        if (maxval(abs(y - y_reconst)) > 1e-12) then
            stop "y and y_reconst do not match!"
        end if
        !write(*, *) y
        !write(*, *) y_reconst
    end subroutine

    subroutine test_over_fitting()
        integer, parameter :: n=1, m=2
        complex(kind(0d0)) :: a(n, m), y(1, n), x(1, m), y_reconst(1, n)
        type(DecomposedMatrix) :: dm
        a(1, 1) = 2.d0
        a(1, 2) = 1.d0

        dm = decompose(a, 1d-10)

        y(1, 1) = 0.2d0

        call fit_impl(y, dm, x)

        y_reconst = transpose(matmul(dm%a, transpose(x)))
        if (maxval(abs(y - y_reconst)) > 1e-12) then
            stop "y and y_reconst do not match!"
        end if
    end subroutine

    subroutine test_under_fitting()
        integer, parameter :: n=2, m=1
        complex(kind(0d0)) :: a(n, m), y(1, n), x(1, m), y_reconst(1, n)
        type(DecomposedMatrix) :: dm
        a(1, 1) = 1.2d0
        a(2, 1) = 1.d0

        dm = decompose(a, 1d-10)

        y(1, 1) = 1.2d0
        y(1, 2) = 1.0d0

        call fit_impl(y, dm, x)
        !write(*,*) "inv_s: ", dm%inv_s
        !write(*,*) "x: ", x

        ! transpose(x): (m, 1)
        ! matmul(dm%a, transpose(x)): (n, m) * (m, 1) = (n, 1)
        y_reconst = transpose(matmul(dm%a, transpose(x)))
        !write(*,*) "y: ", y_reconst
        if (maxval(abs(y - y_reconst)) > 1e-12) then
            stop "y and y_reconst do not match!"
        end if
    end subroutine

    ! fermion
    subroutine test_fermion(preset)
        logical, intent(in) :: preset
        type(IR) :: ir_obj
        integer, parameter :: ndigit = 10, nlambda = 4
        double precision, parameter :: lambda = 1.d1 ** nlambda
        double precision, parameter :: wmax = 1.d0
        double precision :: PI

        double precision, parameter :: beta = lambda/wmax, omega0 = 1.d0/beta
        double precision, parameter :: eps = 1.d-1**ndigit

        complex(kind(0d0)),allocatable :: giv(:,:), gl_ref(:, :), gl_matsu(:, :), gl_tau(:, :), gtau(:, :), &
            gtau_reconst(:, :), giv_reconst(:, :)
        integer n, t, l

        PI =4.D0*DATAN(1.D0)

        if (preset) then
            ir_obj = mk_ir_preset(nlambda, ndigit, beta)
        else
            open(99, file='ir_nlambda4_ndigit10.dat', status='old')
            ir_obj = read_ir(99, beta)
            close(99)
        end if

        if (abs(ir_obj%beta - beta) > 1d-10) then
            stop "beta does not match"
        end if
        if (abs(ir_obj%wmax - wmax) > 1d-10) then
            stop "wmax does not match"
        end if

        ! With ω0 = 1/β,
        !   G(iv) = 1/(iv - ω0),
        !   G(τ=0) = - exp(-τ ω0)/(1+exp(-β ω0)),
        allocate(giv(1, ir_obj%nfreq_f))
        allocate(gtau(1, ir_obj%ntau))
        allocate(gl_ref(1, ir_obj%size))
        allocate(gl_matsu(1, ir_obj%size))
        allocate(gl_tau(1, ir_obj%size))
        allocate(gtau_reconst(1, ir_obj%ntau))
        allocate(giv_reconst(1, ir_obj%nfreq_f))

        ! From Matsubara
        do n = 1, ir_obj%nfreq_f
            giv(1, n) = 1.d0/(cmplx(0d0, PI*ir_obj%freq_f(n)/beta, kind(0d0)) - omega0)
        end do
        call fit_matsubara_f(ir_obj, giv, gl_matsu)

        ! From tau
        !   G(τ=0) = - exp(-τ ω0)/(1+exp(-β ω0)),
        do t = 1, ir_obj%ntau
            gtau(1, t) = - exp(-ir_obj%tau(t) * omega0)/(1.d0 + exp(-beta * omega0))
        end do
        call fit_tau(ir_obj, gtau, gl_tau)

        !do l = 1, ir_obj%size
            !write(*,*) real(gl_matsu(1,l)), real(gl_tau(1,l))
        !end do
        if (maxval(abs(gl_matsu - gl_tau)) > 1d2*eps) then
            stop "gl_matsu and gl_tau do not match!"
        end if

        call evaluate_matsubara_f(ir_obj, gl_matsu, giv_reconst)
        if (maxval(abs(giv - giv_reconst)) > 1d2*eps) then
            stop "giv do not match!"
        end if

        call evaluate_tau(ir_obj, gl_tau, gtau_reconst)
        if (maxval(abs(gtau - gtau_reconst)) > 1d2*eps) then
            stop "gtau do not match!"
        end if

        deallocate(giv, gtau, gl_ref, gl_matsu, gl_tau, gtau_reconst, giv_reconst)
    end subroutine

    ! boson
    subroutine test_boson(preset)
        logical, intent(in) :: preset
        type(IR) :: ir_obj
        integer, parameter :: ndigit = 10, nlambda = 4
        double precision, parameter :: lambda = 1.d1 ** nlambda
        double precision, parameter :: wmax = 1.d0
        double precision :: PI

        double precision, parameter :: beta = lambda/wmax, omega0 = 1.d0/beta
        double precision, parameter :: eps = 1.d-1**ndigit

        complex(kind(0d0)),allocatable :: giv(:,:), gl_ref(:, :), gl_matsu(:, :), gl_tau(:, :), gtau(:, :), &
            gtau_reconst(:, :), giv_reconst(:, :)
        integer n, t

        PI=4.D0*DATAN(1.D0)

        if (preset) then
            ir_obj = mk_ir_preset(nlambda, ndigit, beta)
        else
            open(99, file='ir_nlambda4_ndigit10.dat', status='old')
            ir_obj = read_ir(99, beta)
            close(99)
        end if

        if (abs(ir_obj%beta - beta) > 1d-10) then
            stop "beta does not match"
        end if
        if (abs(ir_obj%wmax - wmax) > 1d-10) then
            stop "wmax does not match"
        end if

        ! With ω0 = 1/β,
        !   G(iv) = 1/(iv - ω0),
        !   G(τ=0) = - exp(-τ ω0)/(1-exp(-β ω0)),
        allocate(giv(1, ir_obj%nfreq_b))
        allocate(gtau(1, ir_obj%ntau))
        allocate(gl_ref(1, ir_obj%size))
        allocate(gl_matsu(1, ir_obj%size))
        allocate(gl_tau(1, ir_obj%size))
        allocate(gtau_reconst(1, ir_obj%ntau))
        allocate(giv_reconst(1, ir_obj%nfreq_b))

        ! From Matsubara
        do n = 1, ir_obj%nfreq_b
            giv(1, n) = 1.d0/(cmplx(0d0, PI*ir_obj%freq_b(n)/beta, kind(0d0)) - omega0)
        end do
        call fit_matsubara_b(ir_obj, giv, gl_matsu)

        ! From tau
        !   G(τ=0) = - exp(-τ ω0)/(1-exp(-β ω0)),
        do t = 1, ir_obj%ntau
            gtau(1, t) = - exp(-ir_obj%tau(t) * omega0)/(1.d0 - exp(-beta * omega0))
        end do
        call fit_tau(ir_obj, gtau, gl_tau)

        !do l = 1, ir_obj%size
            !write(*, *) l, real(gl_tau(1, l)), real(gl_matsu(1, l))
        !end do

        if (maxval(abs(gl_matsu - gl_tau)) > 1d2*eps) then
            stop "gl_matsu and gl_tau do not match!"
        end if

        call evaluate_matsubara_b(ir_obj, gl_matsu, giv_reconst)
        if (maxval(abs(giv - giv_reconst)) > 1d2*eps) then
            stop "gtau do not match!"
        end if

        call evaluate_tau(ir_obj, gl_tau, gtau_reconst)
        if (maxval(abs(gtau - gtau_reconst)) > 1d2*eps) then
            stop "gtau do not match!"
        end if

        deallocate(giv, gtau, gl_ref, gl_matsu, gl_tau, gtau_reconst, giv_reconst)
    end subroutine

end program


Function fnkc2(x)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Save
  fnkc2 = x*exp(-2.0*x/hipr1(42))
  Return
End Function fnkc2


      SUBROUTINE tx2tex( buf, lbuf, ibuf, scr, istop, nready )
!     tx2tex is the execution phase of SIOSEIS proces TX2TP or the
!  transformation from time-space domain to the tau-p space using the
!  slant stack technique developed by Mary Kappus = HOP.
!            HOP is the application of the paper "A new
!            method for slant stacking refraction data" by Henry,
!            Orcutt, and Parker (GRL, Dec 1980).  The problem of
!            slant-stacking seismic records at a number of ranges to
!            synthesize a tau-p curve is posed as a linear inverse
!            problem for fixed frequency.  Using an inner product
!            weighted by (k^2 + b^2)*k (where k is wavenumber and b
!            some real positive number), then the representers are
!            bessel functions of k*range, scaled by 1/(k^2 + b^2),
!            and the model is U(k,w) (vert comp only).  The inverse
!            of the Gram matrix can be found analytically as sums
!            and differences of products of modified bessel functions
!            of b*range. If desired, the tau-p representers can be
!            used to compute the T-X predictions and the misfit of
!            these predictions to the original data.
!                        M.E. KAPPUS 10/86
!                        latest revision 7/88
!
!
!            The program is dimensioned for a max of 200 input
!            seismograms (set in parameter statement mdist in routines
!            HOP,BESFL,GBINV,GGINV,MODEL,SPACE.
!     The following has changed and is no longer true  *************
!            Parameter nmax is (2*200*1026) for data and
!            coefficients + (3*nx) for Gram matrix + 1026 for model
!            + 513 for spectrum.  Allows 200 seismograms at 1024 points
!            each producing 200 tau-p grams of the same length.
!            Parameter ndist limits number of tau-p grams to 300.
!
!
!                             VARIABLES
!
!            tmin,tmax - start and end times to read in from input
!                    traces
!            digit - digitization rate (# samples/sec) of input file -
!            tdpt - time delay per trace - difference in data start
!                   times for adjacent traces in input data.  If input
!                   data all have same data start time tdpt = 0.
!                   The delay represents a constant reduction velocity,
!                   i.e. start time for each trace must be delayed
!                   by same amount relative to previous trace
!            pmin,pmax,np - first,last and number of p's at which to
!                        calculate models (locations of output traces)
!            b - scaling factor for representers
!            fc - cutoff frequency for calculating models
!            pcnti - % taper applied to input data before FFT
!            pcnto - % taper applied to models before inverse FFT
!            irev -  input t-x traces (1=are, 0=are not) in reverse
!                    order (decreasing slowness)
!
!            CALCULATED -
!
!            ipntr(n),igpnt,iapnt,iwmod - pointers for starting loca-
!                      tions of transformed seismograms(ss), gram
!                      matrix(gi), coefficients(a), and model(wmod)
!                      in array s (in COMMON ssgia)
!            kf - point number for end freq at which to do calcs
!            limi,limo - number of points on which to apply taper,
!                        based on the % taper chosen by the user
!            lens - the amount of storage required for array s
!            lub2 - closest power of 2 greater than nt - used for FFT
!            mm - the power associated with lub2
!            nt - number of time points to be read in from each trace
!            nx - number of input traces
!            tapi,tapo - the tapers applied to time(freq) series
!
!          **calls subroutines SPACE,PREFORM,
!          **FFT2,REALTR,GGINV,BALPH,MODEL
!
!            NOTE 1.  times actually start at selected tmin (or taumin)
!                     + 1/digit - ie length of time does not include
!                     start time and does include end time
!            NOTE 2.  values of range (or slowness) may be + or - , but
!                     must all be of the same sign, and must be of
!                     increasing(irev=0) or decreasing(irev=1) order
!              The SEGY trace header pointers:
!
!  mod 17 sep 94 - make percents percents by dividing by 100.
!  mod 3  Oct 94 - Change the memory allocation.  Store the data in the
!              transpose array (COMMON/transp/ss(nmax)) until all data
!              have been read and transformed.  Then use the larger ap
!              memory (COMMON /apmem/ s(1)).
!  mod 7 Oct 94 - change mdist = 200 to mdist = 300 to allow 300 input
!              traces. Should allow 300 output traces as well. Bumped
!              up nmax to reflect larger input size from 262144 to 393216
!              Updated tx2ted.f to reflect larger sizes, ***GMK
!  mod 26 Dec 96 - Allow prestack
!  mod 11 May 07 - Do np preset (to intrcs when np = 0)
!                - make the headers file a segy file.
!  mod 29 May 07 - Use ABS(range) so increasing negative ranges works.
!                - Reset oldrange = 0 after all are done so prestack works
!
      COMMON /segyptr/ llsegptr, lrseqptr, lshotptr, lshtrptr, lrpnptr,
     *                 lrptrptr, itridptr, ldisptr,  lwbdptr,  lsxcoptr,
     *                 lrxcoptr, idelmptr, istmptr,  iendmptr, nsampptr,
     *                 isiptr,   iyrptr,   idayptr,  ihrptr,   iminptr,
     *                 isecptr,  igmtptr,  ldelsptr,  lsmusptr,lemusptr,
     *                 lsisptr,  lwbtsptr, lgatptr,  lssmsptr, lesmsptr,
     *                 lsbptr
!
!             set the TX2TP COMMON blocks
!
      parameter (mdist = 300, ndist = 300, nmax = 262144)
      COMMON/bxs/b,ifx,ilx,nx,x(mdist)
      COMMON/ts/tmin,tmax,nt,tdpt
      COMMON/ps/pmin,pmax,np,dp,p(ndist)
      COMMON/digs/digit,fc,lub2,mm,df,kf,dw,ishift,limo
      COMMON/arbs/icomp,irev,ispec,imft
      COMMON/points/ipntr(mdist),igpnt,iapnt,imod(2*mdist)
      COMMON/transp/ss(nmax)
      COMMON /tx2tp/ sshift, sep(2), nnp, setau(2), bb, ffc, ppcnti,
     *               ppcnto, iirev, fon, dummy, iimft, set(2), lprint,
     *               lunhdr, txprestk, ntx2tp
      INTEGER txprestk
      INTEGER fon
      COMMON /readt/ itunit, numhdr, numdat, ihunit, ireeln, intrcs,
     *               ifmt, nskip, secs, lrenum, isrcf, idtype,
     *               nfskip, jform, itxsi, itxdel
      COMMON /sioap/ iasgnd, irelse, in, iout, nextad, lapsiz, ifree,
     *               iuseap, idecim, mdsize
!****  apmem is 5,000,000
      COMMON /apmem/ s(333333)
      DIMENSION buf(111), lbuf(111), ibuf(111), scr(111)
      INTEGER*2 ibuf
      SAVE
      DATA oldrange/0./, eps/.0001/, nrps/0/
!            set variable types
!
      data da1,da2,pi/3.75,80.0,3.14159265/
      DATA nx/0/
!
!    assume that we only get those traces meant for us, so we don't need
!  a first trace - last trace
!    also assume that process plot does the plotting
!    calculate pointers for array s in COMMON data which holds the data,
!   its spectrum, Gram matrix, the coefficients, and models (SPACE)
!
      IF( istop .LT. 0 ) GOTO 1000                                      ! istop = -1 means there isn't a trace in buf!
      IF( ibuf(itridptr) .GT. 2 ) RETURN
      nx = nx + 1                                                       ! count the traces as they come in
      range = FLOAT(lbuf(ldisptr)) / 1000.                              ! the range (distance) in kilometers
      IF( range .LT. 0. .AND. range .LT. oldrange ) range = ABS(range)
      IF( range .EQ. 0. ) THEN
          range = .00001
          PRINT *,' range of 0. changed to .0001'
      ENDIF
      IF( range .EQ. oldrange ) THEN
          range = range + .00001
          PRINT *,' ***  WARNING  ***  duplicate range ',oldrange,
     *            ' becoming ',range
      ENDIF
      IF( range .LT. oldrange ) THEN                                    ! subroutine gginv requires increasing ranges
          PRINT *,' ***  ERROR  ***  tx2tp requires increasing ranges.'
          STOP
      ENDIF
      oldrange = range
      x(nx) = range
      nsamps = ibuf(nsampptr)
      delay = buf(ldelsptr)                                              ! the time of the first sample in seconds
      si = buf(lsisptr)                                                 ! the sample interval in seconds
      IF( tmin .LT. 0. ) tmin = delay
      IF( ntx2tp .EQ. 0 ) THEN
          itrno = 0
          tmin = set(1)
          IF( tmin .LT. 0. ) tmin = delay                               ! if user didn't give stime, use the delay of the first trace
          tmax = set(2)
          IF( tmax .LT. 0. ) tmax = delay + FLOAT(nsamps-1) * si
          digit = 1. / si                                               ! the sample rate = 1./(sample interval)
! OSU Begin July, 1990 Daniel Sattel
! OSU Deleted the next line.  tdpt gets reset later again.
! OLD        tdpt = sshift
! OSU End
          pmin = sep(1)                                                 ! first p value
          pmax = sep(2)                                                 ! last p value
          np = nnp                                                      ! the number of p's to do
          IF( np .EQ. 0 ) np = intrcs
          b = bb
          fc = ffc
          IF( fc .LE. 0 ) fc = digit / 2.
          pcnti = ppcnti / 100.
          pcnto = ppcnto / 100.
          irev = iirev
          imft = iimft
!      compute least power of 2 over seismogram length for the FFT program
          lub2 = 1
          itemp = (nsamps + 1) / 2
          DO j = 1, 12
             mm = j
             lub2 = lub2 + lub2
             IF( lub2 .GE. itemp ) GOTO 120
          ENDDO
          PRINT *,'trace too long - must be less than 2**12'
          STOP
  120     CONTINUE
          taumin = setau(1)
          taumax = setau(2)
          IF( taumin .GT. 99990. ) THEN
              taumin = tmin
              taumax = tmin + (lub2+lub2)*si
          ENDIF
          df = digit/FLOAT(lub2 + lub2)
          nt = lub2 + lub2
          kf = int(fc/df)
          dw = pi * digit/FLOAT(lub2)
          limi = NINT(pcnti * float(nsamps))
          limo = NINT(pcnto * float(kf))
          ishift = MOD(NINT((taumin-tmin)*(digit+eps)),2*lub2)
          IF (ishift .LT. 0) ishift = ishift + 2*lub2
          tdpt = 0.
          IF( IAND(lprint,2) .NE. 0 ) THEN
              PRINT *,'min t  ',tmin,' max t ',tmax,'  nt ',nt
              PRINT *,'1st p  ',pmin,' last p ',pmax,'  np ',np
              PRINT *,'min tau ',taumin,' max tau ',taumax,' dig ',digit
              PRINT *,'beta ',b,' %input taper',pcnti,' % output ',pcnto
              PRINT *,'seis len ',nsamps,' padded to ',2*lub2
              PRINT *,'cutoff freq',fc,' cutoff pnt',kf,' df=',df,
     &         ' ishift=', ishift
          ENDIF
          CALL podisc( ihunit, 1, 0 )
          CALL podisc( lunhdr, 1, 0 )
          CALL rddiscb( ihunit, scr, 3200, istat )
          CALL wrdiscb( lunhdr, scr, 3200 )
          CALL rddiscb( ihunit, scr, 400, istat )
          CALL wrdiscb( lunhdr, scr, 400 )
      ENDIF
      ndone = 0
      ntx2tp = ntx2tp + 1
!****
!****  make sure the first sample is at tmin and the last is at tmax
!****
      IF( tmin .LT. delay ) THEN
          n = (tmin-delay) / si
          DO i = 1, n
             scr(i) = 0.             ! zero fill from tmin to delay
          ENDDO
          ndone = n
      ENDIF
      itemp = ibuf(58)
      ibuf(58) = 0
      CALL wrdisc( lunhdr, lbuf, numhdr )                               ! save the trace header on disk
      ibuf(58) = itemp
      iout = 0                                                          ! tell rlseap to move the data
      CALL rlseap( buf(numhdr+1), nsamps )                              ! get the data out of the ap or ap simulator
!
!     in loop through all traces read the data, taper and
!     pad (PREFORM), Fourier transform (FFT2), and unscramble
!     the real and imaginary parts (REALTR), account for phase
!     shift if there is varying data start time (FAZE)
!     note:  nt data points are read in and padded
!     out to a power of 2 in PREFORM, but next trace is
!     written over starting at 2*(kf+1) +1, which is how the
!     pointers were set up in SPACE
!
      IF( tmin .GT. delay ) THEN
          istart = (delay - tmin) / si
      ELSE
          istart = 1
      ENDIF
      CALL preform( buf(numhdr+istart), limi, nsamps-istart+1, lub2 )
      DO i = 1, nsamps
         scr(ndone+i) = buf(numhdr+istart+i-1)
      ENDDO
      ndone = ndone + nsamps
      IF( ndone .LT. nt+2 ) THEN
          DO i = 1, nt-ndone+2
             scr(ndone+i) = 0.
          ENDDO
      ENDIF
      CALL FFT2( scr, mm, 0 )
      ipntr(nx) = (nx-1) * (kf+1) * 2 + 1
      iptr = ipntr(nx) - 1
      DO i = 1, nt+2
         ss(iptr + i) = scr(i)
      ENDDO
      CALL REALTR( ss(ipntr(nx)), ss(ipntr(nx)+1), lub2, 2 )
      IF(IAND(lprint,2) .NE. 0) PRINT *,' CALL REALTR. ipntr=',ipntr(nx)
! OSU Begin July, 1990 Daniel Sattel
! OSU Added the following line...
      if (nx.gt.1) tdpt=sshift
! OSU End
      IF ( TDPT .NE. 0. ) THEN
           CALL FAZE( nx, ss(ipntr(nx)))
           IF( IAND(lprint,2) .NE. 0 ) PRINT *,' CALL FAZE. tdpt=',tdpt,
     &           ' ipntr=',ipntr(nx)
      ENDIF
      nready = 0                                                        ! no output traces ready yet!
      IF( txprestk .LE. 0 ) THEN
          IF( istop .EQ. 0 ) RETURN
      ELSE
          IF( lbuf(51) .LT. 0 ) nrps = nrps + 1
          IF( nrps .NE. txprestk ) RETURN
          nrps = 0
      ENDIF
!
!            test for enough room in arrays s,x, and p
!
 1000 CONTINUE
      IF( np .EQ. 0 ) np = nx
      dp = (pmax-pmin)/(np-1)
      DO i = 1, np
         p(i) = pmin + (i-1)*dp
      ENDDO
!

      CALL SPACE(nx,np,lens)
      IF( IAND(lprint,2) .NE. 0) PRINT *,' CALL SPACE( ',nx,np,lens
      CALL inap(s,10000)                                                   ! get the ap array allocated
!  new compilers don't like the following for some reason
      PRINT *,' **** WARNING  ****  tx2tp compiler issue.'
      PRINT *,' Please contact the SIOSEIS authors.'
      DO i = 1, nmax
         s(i) = ss(i)
      ENDDO
      IF (NX.GT.MDIST.OR.NP.GT.NDIST.OR.LENS.GT.lapsiz) THEN
          PRINT *,'max storage exceeded - decrease nx or np.'
          PRINT *,' nx=',nx,' np=',np,' lens=',lens
          STOP
      ENDIF
!
!            test for size of arguments of Bessel function to
!            determine which subroutine to use or if arguments are
!            too large to do at all
!
      CALL BESFL(ymin,ymax,ydif)
      IF( IAND(lprint,2) .NE. 0 ) PRINT *,
     &   ' CALL BESFL, b=',b,' ymin=',ymin,' ymax=',ymax,' ydif=',ydif
!
!            use appropriate subroutine to compute Gram matrix inverse
!            and print it out
!
      IF (ymax.LT.da2) THEN
          ibr = 0
          CALL GGINV(s(igpnt))
          IF( IAND(lprint,2) .NE. 0) PRINT *,' CALL GGINV( ',igpnt
      ELSE IF (ymax.GE.da2.AND.ymin.GT.da1.AND.ydif.LT.da2) THEN
          ibr = 1
          CALL GBINV(s(igpnt))
          IF( IAND(lprint,2) .NE. 0) PRINT *,' CALL GBINV( ',igpnt
      ELSE
          PRINT *,' ******  TX2TP error   ******'
          PRINT '(a,/,a,/,a)','incompatible range of Bessel fx arguments
     &        b*x','if b*xmax>80, b*xmin must be >3.75 and b*(2*dx)',
     &        ' must be<80 - adjust ranges of x or b to conform'
          stop
      ENDIF
!
!            compute the alpha vector of coefficients, putting the
!            result in s, starting at pointer iapnt
!
      IF( IAND(lprint,2) .NE. 0 ) PRINT *,' CALL BALPH(nx,kf',nx,kf,
     &      ipntr(1), igpnt, iapnt
      CALL BALPH(nx,kf,s(ipntr(1)),s(igpnt),s(iapnt))
!
      nready = np
      itrno = 0
      IF( IAND(lprint,2) .NE. 0 ) PRINT *,' p=',(p(i),i=1,5)
      IF( IAND(lprint,2) .NE. 0 ) PRINT *,' x=',(x(i),i=1,5)
      CALL podiscb( lunhdr, 1, 3600 )
      RETURN
!
      ENTRY getntp( buf, lbuf, ibuf )
!****
!****   return a trace, which is really a tau-p gram
!****
!
!             For each output p, build the model for each
!             frequency, putting these (for fixed p) in s vector
!             starting at pointer imod (MODEL),
!             taper and pad the models (PREFORM),
!             unscramble the real and imaginary parts (REALTR),
!             inverse Fourier transform (FFT2).
!
      itrno = itrno + 1                                                 ! increment the trace number
      CALL MODEL(itrno,s(iapnt),s(imod(1)))
      IF( IAND(lprint,2) .NE. 0) PRINT *,' CALL MODEL( ',
     &    itrno,iapnt,imod(1)
      CALL PREFORM(s(imod(1)),limo,2*(kf+1),lub2)
      IF( IAND(lprint,2) .NE. 0) PRINT *,' CALL PERFORM( ',
     &    imod(1), limo,2*(kf+1),lub2
      CALL REALTR(s(imod(1)),s(imod(1)+1),lub2,-2)
      IF( IAND(lprint,2) .NE. 0) PRINT *,' CALL REALTR( ',
     &     imod(1),imod(1)+1,lub2
      CALL FFT2(s(imod(1)),mm,1)
      IF( IAND(lprint,2) .NE. 0) PRINT *,' CALL FFT2( ',imod(1),mm
!****
!****   create the output trace headers - make it up as we go
!****
      CALL rddisc( lunhdr, buf, numhdr, istat )
      IF( istat .NE. numhdr ) THEN
          CALL podisc( lunhdr, 2, -numhdr )
          CALL rddisc( lunhdr, buf, numhdr, istat )
          IF( istat .NE. numhdr ) PRINT *,
     * ' ***  WARNING  ***  tx2tp had a problem with the trace headers.'
      ENDIF
      IF( lbuf(7) .NE. 0 ) THEN
          lbuf(7) = itrno
      ELSE
          lbuf(4) = itrno
      ENDIF
      ibuf(itridptr) = 1                                                ! it's a live trace
      lbuf(ldisptr) = NINT( p(itrno)*1000.)                             ! put the p value in the range, but make it * 1000.
      itemp = NINT((taumax-taumin)/si)
      numdat = MIN( lub2+lub2, itemp )
      ibuf(nsampptr) = numdat
      ibuf(isiptr) = NINT( si*1000000. )                                ! the sample intervat in milliseconds
      buf(lsisptr) = si                                                 ! sample interval in seconds
      buf(ldelsptr) = taumin                                            ! the tau of the first sample
      ibuf(idelmptr) = NINT(taumin*1000.)
!****
!****   move the trace to buf.  The trick here is that the tau data might
!****  not have the same origin as the time data.  e.g.  If the data is
!****  4 mil, from 9 - 13 secs; after forward and inverse fft, the data
!****  goes from 9 to 13.096 (9+1024*.004). Because of "wraparound", the
!****  same data is for times 0.808 to 4.900, 4.904 to 8.996, 9.000 to 13.092
!****  13.096 to 17.192.
!****  variable ishift was calculated earlier -
!****          ishift = MOD(NINT((taumin-tmin)*(dig+eps)),2*lub2)
!****
      index = numhdr
      jndex = imod(1) + ishift -1
      n = lub2 + lub2 - ishift
      DO i = 1, n
         buf(index+i) = s(jndex+i)
      ENDDO
      index = numhdr + n
      jndex = imod(1) - 1
      n = numdat - n
      IF( n .GT. 0 ) THEN
          DO i = 1, n
             buf(index+i) = s(jndex+i)
          ENDDO
      ENDIF
      lbuf(51) = 0
      IF( itrno .EQ. np ) THEN                                          ! if no more, reset the trace header
          itrno = 0
          CALL podisc( lunhdr, 1, 0 )
          nx = 0
          ntx2tp = 0
          oldrange = 0.
          IF( txprestk .NE. 0 ) lbuf(51) = -1
      ENDIF
!****
!****   set stuff for the SEGY binary tape header
!****
      in = 0                                                            ! the trace is not in the ap!
      intrcs = np                                                       ! each output record (shot) will contain np traces
      idtype = 7                                                        ! the data type is tau-p
      itxsi = NINT( 1./digit*1000000.)                                  ! the tx domain sample interval in mics
      itxdel = NINT( tmin*1000. )                                       ! the time of start of data in tx in mils
      oldrange = 0
      RETURN
      end
!*********************************************************************
      subroutine balph(nx,kf,ss,gi,a)
!*********************************************************************
!            builds the complex matrix of coefficients, alpha,stored
!            in array s starting at iapnt.  here it is stored in 3-d
!            rep - 2(real+complex) by nx by kf+1 (number of freqs)
!            called a for alpha.  alpha = sum over x of gram matrix
!            element times fourier-transformed data
!
!          **CALLS NO OTHER SUBROUTINES**
!
      dimension a(2,nx,kf+1), gi(3*nx-2), ss(2,kf+1,nx)
      do 630 j = 1,kf+1
!
!            compute first element (real+complex) outside of loop
!
      a(1,1,j) = gi(1)*ss(1,j,1) + gi(2)*ss(1,j,2)
      a(2,1,j) = gi(1)*ss(2,j,1) + gi(2)*ss(2,j,2)
      ig = 2
!
!            compute rest (except last) element in loop
!
         do 620 n = 2,nx-1
         a(1,n,j) = 0.0
         a(2,n,j) = 0.0
             do 610 m = 1,3
             im = n + m - 2
             ig = ig + 1
             a(1,n,j) = a(1,n,j) + gi(ig)*ss(1,j,im)
             a(2,n,j) = a(2,n,j) + gi(ig)*ss(2,j,im)
  610        continue
  620    continue
!
!            compute last element (real+complex) outside of loop
!
      a(1,nx,j) = gi(3*nx-3)*ss(1,j,nx-1) + gi(3*nx-2)*ss(1,j,nx)
      a(2,nx,j) = gi(3*nx-3)*ss(2,j,nx-1) + gi(3*nx-2)*ss(2,j,nx)
  630 continue
      return
      end
!*********************************************************************
      subroutine besfl(ymin,ymax,ydif)
!*********************************************************************
!            This subroutine tests for arguments (b*x) of the Bessel
!            functions which will be too large for the inverse Gram
!            matrix subroutines to handle. Actually the difference
!            between two of these is required, and the failure
!            conditions depend on this.  Subroutine GGINV can handle
!            computations when both arguments are <80.  Subroutine
!            GBINV can handle the computations if one argument is >80
!            as long as the other is >3.75, and the difference between
!            the two is <80.  This subroutine determines which
!            Gram matrix subroutine to call.
!
!         ** CALLS NO OTHER SUBROUTINES**
!
      parameter (mdist = 300)
      COMMON/bxs/b,ifx,ilx,nx,x(mdist)
      ymin = b * x(1)
      ymax = b * x(nx)
      ydif = b * 2.0 * (x(nx) - x(1))/float(nx-1)
      return
      end
!**********************************************************************
      subroutine faze(n,ss)
!**********************************************************************
!            This subroutine corrects for a phase shift if the input
!            data does not have a constant start time - tdpt is the
!            delay in start time between adjacent traces
!
!          **CALLS NO OTHER SUBROUTINES**
!
      COMMON/ts/tmin,tmax,nt,tdpt
      COMMON/digs/digit,fc,lub2,mm,df,kf,dw,ishift,limo
      dimension ss(2,lub2+1)
      data pi/3.14159265/
      do 400 i = 1,lub2+1
! OSU Begin July, 1990 Daniel Sattel
! OSU Added the "2x"
         arg = (2*dw * (i-1)) * (tdpt * (n-1))
! OLD         arg = (dw * (i-1)) * (tdpt * (n-1))
! OSU End
         tre = cos(arg) * ss(1,i) - sin(arg) * ss(2,i)
         tim = sin(arg) * ss(1,i) + cos(arg) * ss(2,i)
         ss(1,i) = tre
         ss(2,i) = tim
  400 continue
      return
      end
!**********************************************************************
      subroutine gbinv(gi)
!**********************************************************************
!            for the case of large arguments b*x
!            computes the inverse of the gram matrix gi directly.
!            as this is tridiagonal, it is stored as a 3*nx - 2 vector
!          **CALLS FUNCTION ABO**
!
      parameter (mdist = 300)
      COMMON/bxs/b,ifx,ilx,nx,x(mdist)
      dimension gi(3*nx-2),c(2),d(2),b1(mdist),b2(mdist),b3(mdist),
     &          b4(mdist)
!
!            compute products of modified Bessel functions
!
      do 500 n = 2,nx-1
      b1(n) = ABO(b*x(n),b*x(n+1))
      b2(n) = ABO(b*x(n+1),b*x(n))
      b3(n) = ABO(b*x(n+1),b*x(n-1))
      b4(n) = ABO(b*x(n-1),b*x(n+1))
  500 continue
!
!            use AIO type routine to compute factors for term g1
!            and AKO type routine to compute factors for term gn
!
      do 510 i = 1,2
      t = 3.75/(b*x(i))
      d(i)=.39894228+t*(.01328592+t*(.00225319-t*(.00157565-t*(.00916281
     &     -t*(.02057706-t*(.02635537-t*(.01647633-t*.00392377)))))))
      s = 2.0/(b*x(nx-2+i))
      c(i) = 1.25331414-s*(.07832358-s*(.02189568-s*(.01062446-
     &       s*(.00587872-s*(.00251540-s*.00053208)))))
  510 continue
!
!            compute ratios of 1st two bessel fxs of first kind and
!            last two of 2nd kind.  used to scale first and last
!            matrix elements.
!
      g1 = -(d(2)/d(1)) * exp(b*(x(2)-x(1))) * sqrt(x(1)/x(2))
      gn = -(c(1)/c(2)) * exp(b*(x(nx)-x(nx-1))) * sqrt(x(nx)/x(nx-1))
!
!            compute elements of inverse matrix, using tridiagonality
!
      gi(2) = 1.0/(ABO(b*x(2),b*x(1)) - ABO(b*x(1),b*x(2)))
      gi(1) = g1 * gi(2)
!
      do 520 i = 2,nx-1
      kp = (3*i) - 3
      kd = (3*i) - 2
      km = (3*i) - 1
      gi(kp) = gi(km-3)
      gi(km) = 1.0/(b2(i) - b1(i))
      gid = b4(i) - b3(i)
      gi(kd) = gi(km) * gi(kp) * gid
  520 continue
!
      gi(3*nx-3) = gi(3*nx-4)
      gi(3*nx-2) = gn * gi(3*nx-3)
      return
      end
!**********************************************************************
      subroutine gginv(gi)
!**********************************************************************
!            computes the inverse of the gram matrix gi directly.
!            as this is tridiagonal, it is stored as a 3*nx - 2 vector
!
!          **CALLS FUNCTIONS AIO AND AKO**
!
      parameter (mdist = 300)
      COMMON/bxs/b,ifx,ilx,nx,x(mdist)
      dimension bi(mdist),bk(mdist),gi(3*nx-2)
!
!            compute modified bessel fxs(beta*x)
!
      do 500 n = 1,nx
      bi(n) = AIO(b*x(n))
      bk(n) = AKO(b*x(n))
  500 continue
!
!            compute ratios of 1st two bessel fxs of first kind and
!            last two of 2nd kind.  used to scale first and last
!            matrix elements.
!
      g1 = (-bi(2)/bi(1))
      gn = (-bk(nx-1)/bk(nx))
!
!            compute elements of inverse matrix, using tridiagonality
!
      gi(2) = 1.0/((bi(1)*bk(2)) - (bi(2)*bk(1)))
      gi(1) = g1 * gi(2)
!
      do 520 i = 2,nx-1
      kp = (3*i) - 3
      kd = (3*i) - 2
      km = (3*i) - 1
      gi(kp) = gi(km-3)
      gi(km) = 1.0/((bi(i)*bk(i+1)) - (bi(i+1)*bk(i)))
      gid = ((bi(i+1)*bk(i-1)) - (bi(i-1)*bk(i+1)))
      gi(kd) = gi(km) * gi(kp) * gid
  520 continue
!
      gi(3*nx-3) = gi(3*nx-4)
      gi(3*nx-2) = gn * gi(3*nx-3)
      return
      end
!*****************************************************************
      subroutine model(i,a,wmod)
!*****************************************************************
!            forms the representer = Jo(kx)/(k**2 + b**2) and the
!            model = sum of representer times coefficient (alpha)
!            for each freq separately for fixed p.  result is a vector
!            of models, one for each freq.
!            the fourier transform of the models gives tau-p.
!
!          **CALLS FUNCTION AJO**
!
      parameter (mdist = 300, ndist = 300)
      COMMON/bxs/b,ifx,ilx,nx,x(mdist)
      COMMON/ps/pmin,pmax,np,dp,p(ndist)
      COMMON/digs/digit,fc,lub2,mm,df,kf,dw,ishift,limo
      dimension wmod(2,lub2+1),a(2,nx,kf+1)
!
      do 860 j = 1,kf+1
      wmod(1,j) = 0.0
      wmod(2,j) = 0.0
      w = float(j-1) * dw
      wp2b2 = (w*p(i))**2 + b**2
!
!            form the nth representer, rep.  multiply by alpha and sum
!            to form the model (for fixed freq), wmod.
!
          do 820 n = 1,nx
          bf = AJO(x(n)*w*p(i))
          rep = bf/wp2b2
          wmod(1,j) = wmod(1,j) + a(1,n,j)*rep
          wmod(2,j) = wmod(2,j) + a(2,n,j)*rep
  820     continue
  860 continue
      return
      end
!*********************************************************************
      subroutine preform(ss,lim,nn,lub2)
!*********************************************************************
!
!           tapers and pads data before Fourier transform
!
!         **CALLS NO OTHER SUBROUTINES**
!
      dimension ss(2*(lub2+1))
      data pi/3.14159265/
!
!           taper with cos**2 taper, amount specified by user
!
      IF (LIM.GT.0) THEN
          do 310 j = 1,lim
             tap = 0.5 * (1.0 - cos((j-1.)*pi/float(lim)))
             ss(j) = ss(j) * tap
             ss(nn-j+1) = ss(nn-j+1) * tap
  310     continue
      ENDIF
!
!           pad end with z1eroes to power of two
!
      IF (NN.LT.2*LUB2) THEN
          do 320 j = nn+1,2*(lub2+1)
             ss(j) = 0.0
  320     continue
      ENDIF
      return
      end
!******************************************************************
      subroutine space(nx,np,lens)
!******************************************************************
!           computes the values of the pointers for array s in COMMON
!           data.  IPNTR locates the beginning of each data trace -
!           one for each p.  only 2*(kf+1) points are allowed for each
!           trace - accounting for the real and imaginary part of the
!           Fourier-transformed data up to some cutoff point kf assoc-
!           iated with user-selected cutoff frequency fc. one extra
!           'trace' is allowed in order to store the spectrum of the
!           data (it is later overwritten by the spectrum of the model)
!           IGPNT locates the beginning of the inverse Gram matrix
!           IAPNT locates the beginning of the vector of coefficients.
!           IMOD locates the beginning of each model
!           trace - one for each p. 2*(lub2+1) points are allowed.
!
!      **CALLS NO OTHER SUBROUTINES**
!
!            set COMMONs and variable types
!
      parameter (mdist = 300)
      COMMON/digs/digit,fc,lub2,mm,df,kf,dw,ishift,limo
      COMMON/points/ipntr(mdist),igpnt,iapnt,imod(2*mdist)
!
!            compute pointers
!
      igpnt = ipntr(nx) + lub2+1
      iapnt = igpnt + 3*nx-2
      imod(1) = iapnt + ((kf+1)*2*nx)
!
!             compute overall length
!
      lens = imod(1) + 2*(lub2+1)
      return
      end
!******************************************************************
      FUNCTION AJO(X)
!*********************************************************************
!$$$$ CALLS NO OTHER ROUTINES
!  BESSEL FUNCTION OF THE 1ST KIND, 0TH ORDER, REAL ARGUMENT.
!  POLYNOMIAL APPROXIMATIONS FROM ABRAMOWITZ+STEGUN PP369-370.
      Y=ABS(X)
      IF (Y.GT. 3.0) GO TO 2000
      T=(X/3.0)**2
      AJO=1.0-T*(2.2499997-T*(1.2656208-T*(.3163866-T*(.0444479-T*
     +  (.0039444-T*.00021)))))
      RETURN
 2000 T=3.0/Y
      F=.79788456+T*(-.00000077+T*(-.0055274+T*(-.00009512+T*
     +  (.00137237+ T*(-.00072805+T*.00014476)))))
      A=.78539816-T*(-.04166397+T*(-.00003954+T*(.00262573+T*
     +  (-.00054125 +T*(-.00029333+T*.00013558)))))
      AJO=F*COS(Y-A)/SQRT(Y)
      RETURN
      END                                                               AJO
!*****************************************************************
      FUNCTION AIO(X)
!*****************************************************************
!$$$$$ CALLS NO OTHER ROUTINES
!  MODIFIED BESSEL FUNCTION OF THE 1ST KIND, 0TH ORDER, REAL ARGUMENT
!  POLYNOMIAL APPROXIMATIONS FROM ABRAMOWITZ+STEGUN, P378.
      Y=ABS(X)
      IF (Y.GT. 3.75) GO TO 2000
      T=(X/3.75)**2
      AIO=1.0+T*(3.5156229+T*(3.0899424+T*(1.2067492
     +  +T*(.2659732+T*(.0360768+T*.0045813)))))
      RETURN
 2000 T=3.75/Y
      A=.39894228+T*(.01328592+T*(.00225319-T*(.00157565-T*(.00916281
     +  -T*(.02057706-T*(.02635537-T*(.01647633-T*.00392377)))))))
      AIO=A*EXP(Y)/SQRT(Y)
      RETURN
      END                                                               AIO
!
!*****************************************************************
      FUNCTION AKO(X)
!*****************************************************************
!$$$$ CALLS NO OTHER ROUTINES
! COMPUTES MODIFIED BESSESL FUNCTIONS OF THE 2ND KIND (K), REAL ARGUMENT
!  WITH TRUNCATED EXPRESSIONS OF ABRAMOWITZ + STEGUN PP378- 9.
      IF (X.GT. 2.0) GO TO 2000
      T=X/3.75
      T=T*T
      AIO=1.0+T*(3.5156229+T*(3.0899424+T*(1.2067492+T*(.2659732+
     +  T*(.0360768+T*.0045813)))))
      Y=.25*X*X
      AKO=-AIO*ALOG(.5*X)-.57721566+Y*(.42278420+Y*(.23069756+
     +  Y*(.03488590+Y*(.00262698+Y*(.00010750+Y*.00000740)))))
      RETURN
 2000 Y=2.0/X
      T=1.25331414-Y*(.07832358-Y*(.02189568-Y*(.01062446-
     +  Y*(.00587872-Y*(.00251540-Y*.00053208)))))
      AKO=T*EXP(-X)/SQRT(X)
      RETURN
      END                                                               AKO
!*******************************************************************
      FUNCTION ABO(x,y)
!*******************************************************************
!        ***CALLS NO OTHER ROUTINES***
!        COMPUTES PRODUCT OF MODIFIED BESSEL FUNCTION OF 1ST KIND (AIO)
!        ARGUMENT Y WITH MODIFIED BESSEL FUNCTION OF 2ND KIND (AKO)
!        ARGUMENT X WHEN BOTH ARGUMENTS ARE GREATER THAN 3.75
!        IS JUST COMBINATION OF AIO AND AKO ABOVE
!
!        preliminary part of AKO(x)
      s = 2.0/x
      c = 1.25331414-s*(.07832358-s*(.02189568-s*(.01062446-
     +  s*(.00587872-s*(.00251540-s*.00053208)))))
!        preliminary part of AIO(y)
      t = 3.75/y
      d = .39894228+t*(.01328592+t*(.00225319-t*(.00157565-t*(.00916281
     +  -t*(.02057706-t*(.02635537-t*(.01647633-t*.00392377)))))))
!        combine fintal expression
      ABO = c*d*exp(y-x)/sqrt(x*y)
      return
      end


      SUBROUTINE LAGR(C)
*
*
*       Lagrangian radii.
*       -----------------
*
      INCLUDE 'common6.h'
      REAL*8 R2,MRT,RT
      COMMON/WORK1/ R2(NMAX)
      PARAMETER (LX=11)
      REAL*8 C(3),FLAGR(LX),RLAGR(LX),RM(LX),DENS(LX),VR(LX),AVM(LX)
*     DATA FLAGR/-1.9,-1.7,-1.5,-1.3,-1.1,-.9,-.7,-.5,-.3,-.1/
*     DATA FLAGR/0.001,0.002,0.005,0.01,0.02,0.05,0.1,0.2,0.3,0.4,0.5,
*    &           0.75,0.9/
      DATA FLAGR/0.01,0.02,0.05,0.1,0.2,0.3,0.4,0.5,0.625,0.75,0.9/
*
*
*       Set square radii of single particles & c.m. bodies.
      NP = 0
      DO 10 I = IFIRST,NTOT
          NP = NP + 1
          R2(NP) = (X(1,I) - C(1))**2 + (X(2,I) - C(2))**2 +
     &                                  (X(3,I) - C(3))**2
          JLIST(NP) = I
   10 CONTINUE
*
*       Sort square distances with respect to the centre C.
      CALL SORT1(NP,R2,JLIST)

*       Determine Lagrangian radii for specified mass fractions.
      ZM = 0.0
      DO 20 IL = 1,LX
          ZM1 = ZM
          ZM = 0.0
          ZMH = FLAGR(IL)*ZMASS
          VM2 = 0.0
          IF (IL.GT.1) THEN
              R1 = SQRT(R2(I))
              IPREV = I
          ELSE
              R1 = 0.0
              IPREV = 0
          END IF
          I = 0
   15     I = I + 1
          IM = JLIST(I)
          ZM = ZM + BODY(IM)
*       Sum mass-weighted square velocity in current shell.
          IF (ZM.GT.ZM1) THEN
              VM2 = VM2 + BODY(IM)*(XDOT(1,IM)**2 + XDOT(2,IM)**2 +
     &                                              XDOT(3,IM)**2)
          END IF
          IF (ZM.LT.ZMH) GO TO 15
          RLAGR(IL) = SQRT(R2(I))
          IF (KZ(7).LT.5) GO TO 20
*       Form mean square velocity and density (print outer shell radii).
          DM = ZM - ZM1
          IF (ABS(DM).LT.1.0D-10) THEN
              VR(IL) = 0.0
          ELSE
              VR(IL) = SQRT(VM2/DM)
          END IF
          DV = 2.0*TWOPI/3.0*(R2(I)**1.5 - R1**3)
          DENS(IL) = DM/DV
          IF (DENS(IL).LE.0.0D0) DENS(IL) = 1.0
          RM(IL) = 0.5*(R1 + RLAGR(IL))
*       Obtain the average mass in solar units.
          IF (I.GT.IPREV) THEN
              AVM(IL) = DM/FLOAT(I - IPREV)*SMU
          ELSE
              AVM(IL) = 0.0
          END IF
   20 CONTINUE
*
*       Obtain half-mass radius separately.
      ZM = 0.0
      ZMH = 0.5*ZMASS
      I = 0
   25 I = I + 1
      IM = JLIST(I)
      ZM = ZM + BODY(IM)
      IF (ZM.LT.ZMH) GO TO 25
*
*       Replace approximate half-mass radius by actual value.
      RSCALE = SQRT(R2(I))
*
*       Determine tidal radius and mass if kz(14) = 2.
      if (kz(14).eq.2.and.tidal(1).ne.0.) then
      I = np
      mrt = zmass
   30 continue
      if (mrt.gt.0.) then
         rt = (mrt/tidal(1))**(1./3.)
      else
         rt = 0.0
      endif
      IF (sqrt(r2(i)).gt.rt.and.rt.gt.0.and.i.gt.1) then
         IM = JLIST(I)
         Mrt = Mrt - BODY(IM)
         i = i - 1
         GO TO 30
      endif
      endif

      IF ((KZ(7).EQ.2.OR.KZ(7).EQ.4).AND.TIME.GE.TNEXT) THEN
          IF (KZ(14).EQ.2) WRITE (6,*)  tphys,mrt,rt
      END IF
*
      IF (KZ(7).GE.3.AND.TIME.GE.TNEXT) THEN
          IF (KZ(14).EQ.2) WRITE (14,35)  tphys, mrt, rt
   35     FORMAT (3X,'TIDAL RADIUS    TPHYS MRT RT ',F8.1,1P,2E10.2)
      END IF
*
*       Check output options (line printer or unit 14 or both).
      IF (KZ(7).EQ.2.OR.KZ(7).EQ.4.AND.TIME.GE.TNEXT) THEN
          WRITE (6,40)  (LOG10(RLAGR(K)),K=1,LX)
   40     FORMAT (/,' LAGR:  ',13F7.3)
      END IF
*
      IF (KZ(7).GE.3.AND.TIME.GE.TNEXT) THEN
          WRITE (14,50)  TTOT, (LOG10(RLAGR(K)),K=1,LX)
   50     FORMAT ('  LAGR:  ',F7.1,13F7.3)
          CALL FLUSH(14)
      END IF
*
      IF (KZ(7).EQ.5.AND.TIME.GE.TNEXT) THEN
          WRITE (26,60)  TTOT, (DENS(K),K=1,LX)
   60     FORMAT ('  DENSITY (T =',F7.1,'): ',1P,13E10.2)
          WRITE (26,65)  (RM(K),K=1,LX)
   65     FORMAT ('  DISTANCE:  ',1P,13E10.2)
          CALL FLUSH(26)
          WRITE (27,70)  TTOT, (VR(K),K=1,LX)
   70     FORMAT ('  VELOCITY (T =',F7.1,'): ',1P,13E10.2)
          CALL FLUSH(27)
          WRITE (36,75)  TTOT, (AVM(K),K=1,LX)
   75     FORMAT ('  AVERAGE MASS (T =',F7.1,'): ',13F7.3)
          CALL FLUSH(36)
      END IF
      IF (KZ(7).EQ.6.AND.TIME.GE.TNEXT) THEN
          WRITE (28,80)  TTOT, (AVM(K), RM(K),K=1,LX)
   80     FORMAT (' PAIRWISE <M> <RM> (T =',F7.1,'): ',
     &                                13(0P,F7.3,1P,E10.2))
          CALL FLUSH(28)
      END IF
*
      RETURN
*
      END