      subroutine runC_00i(k,l,i1,DetGr,f,Gtwiddle,Gtt,
     . Shat2,Shat3,Shat3zz,S00i,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,n,m,i1,np
      parameter(np=2)
      double precision DetGr,Gtwiddle(np,np),Gtt(np,np,np,np),f(np)
      double complex S00i(np,-2:0),Shat3zz(np,-2:0),
     . Shat2(np,np,-2:0),Shat3(np,z2max,-2:0),pole,bit

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit
     . +Gtt(k,n,l,m)*(f(n)*Shat2(m,i1,ep)
     . +2d0*delta(n,i1)*Shat3zz(m,ep)-f(n)*f(m)*Cv(ci(i1)+N0,ep)
     . -2d0*(f(n)*delta(m,i1)+f(m)*delta(n,i1))*Cv(cc00+N0,ep))
      enddo
      enddo
      pole=0d0
      if (ep.ge.-1) pole=-4d0*Gtwiddle(k,l)*Cv(czzi(i1)+N0,ep-1)

      Cv(czzi(i1)+N0,ep)=
     . -(pole
     . +DetGr*Cv(ciii(z3(k,l,i1))+N0,ep)
     . -Gtwiddle(k,l)*S00i(i1,ep)
     . -Gtwiddle(1,l)*Shat3(1,z2(k,i1),ep)
     . -Gtwiddle(2,l)*Shat3(2,z2(k,i1),ep)
     . +Gtwiddle(k,l)*(Shat3(1,z2(1,i1),ep)
     .                +Shat3(2,z2(2,i1),ep))
     . +bit)/(10d0*Gtwiddle(k,l))

      enddo

      return
      end


module sznullgeo
  use precision1, only : dp
  use constants
  use szgeom
  use utils, only : ang2vec
  implicit none

  private

  public :: rayshoot_dr

contains

    subroutine rayshoot_dr(initial_pos,theta_local_sky,phi_local_sky,yout,iexit,val_exit)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The exit options are                                                        !
!                                                                             !
!      iexit = 1    compute luminosity distance out to a fixed redshift       !
!      iexit = 2    compute redshift out to a fixed luminosity distance       !
!      otherwise    compute redshift out to a fixed comoving time in the past !
!                                                                             !
! the fixed value is specified by val_exit                                    !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        real(dp), intent(in)  :: initial_pos(3)
        real(dp), intent(in)  :: theta_local_sky
        real(dp), intent(in)  :: phi_local_sky
        real(dp), intent(out) :: yout
        integer,  intent(in)  :: iexit
        real(dp), intent(in)  :: val_exit
        real(dp), dimension(4) :: pvi,nvi
        real(dp), dimension(:), allocatable :: yi,yf
        real(dp) :: kti,ktf,si,ds,t_init,zp1
        t_init=0._dp !hardcoded
        si=0._dp
        ds=1.e-2_dp
        call construct_ray(t_init,initial_pos,theta_local_sky,phi_local_sky,pvi,nvi)
        if (iexit == 1 .or. iexit == 2) then
            if (val_exit < 0.) STOP 'exit value must be positive'
            !null geodesics and DA
            allocate(yi(1:10))
            allocate(yf(1:10))
            yi(1:4)=nvi
            yi(5:8)=pvi
            yi(9)=1._dp  !dDA/ds
            yi(10)=0._dp !DA
        else
            if (val_exit > 0.) STOP 'exit value must be negative'
            !null geodesics only
            allocate(yi(1:8))
            allocate(yf(1:8))
            yi(1:4)=nvi
            yi(5:8)=pvi
        end if
        call rayshoot(si,yi,ds,yf,iexit,val_exit)
        if (iexit == 1) then
            !return dL at given z
            zp1=val_exit+1._dp
            yout=yf(10)*zp1*zp1
        else
            !return z (either at given t or dL)
            kti=yi(1) !k^t at observer
            ktf=yf(1) !k^t at source
            zp1=abs(ktf/kti)
            yout=zp1-1._dp
        end if
        deallocate(yf)
        deallocate(yi)
    end subroutine rayshoot_dr

    subroutine rayshoot(si,yinit,ds,yf,iexit,val_exit)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Solve the null geodesic equation as a first order system     !
! until synchronous time t reached (some specified point in    !
! the past)                                                    !
!                                                              !
! note                                                         !
!       y = (k^\mu, x^\mu [, dDA/ds, DA])                      !
!       dy = (dk^\mu/ds, dx^\mu/ds [, d2DA/ds2, dDA/ds])       !
!       i.e.  y(5)=t, y(6)=r, y(7)=\theta, y(8)=\phi           !
!             [y(9)=dDA/ds, y(10)=DA]                          !
!                                                              !
! where s is affine parameter                                  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        use utils, only : dopri_stepper,controller,ydout,zbrent,rtbis
        implicit none
        real(dp), intent(inout) :: si,ds
        real(dp), dimension(:), intent(in) :: yinit
        real(dp), dimension(size(yinit)), intent(out) :: yf
        integer, intent(in) :: iexit
        real(dp), intent(in) :: val_exit
        real(dp), dimension(size(yinit)) :: yi,yo,dyi,dyo
        real(dp), dimension(7,size(yinit)) :: k
        real(dp), parameter :: sacc=1.e-9_dp
        real(dp) :: dsi,so,sf,zo,zp1,dL
        real(dp) :: atol,rtol,errold,err
        logical reject
        atol=1.e-8_dp
        rtol=1.e-10_dp
        reject=.true.
        errold=1.e-4_dp
  1     yi=yinit
        call ode_null(si,yi,dyi)
        do
            call dopri_stepper(ode_null,ds,si,so,k,yi,yo,dyi,dyo,err,atol,rtol)
            call controller(err,errold,reject,ds)
! Guard against solution getting stuck
            if (ds < 1.e-14) then
                write(*,*) 'stuck at (t,r,theta,phi) = ', yo(5:8)
                write(*,*) 'restarting do loop with lower tolerance'
                atol=atol*10._dp
                rtol=rtol*10._dp
                goto 1
            end if
            dsi=ds
            if (reject) then
                cycle !retry with new ds
            else
                errold=err
! Exit strategy given by iexit and exit value = val_exit
                if (iexit == 1) then
                    zo=abs(yo(1)/yinit(1))-1._dp
                    if (zo >= val_exit) EXIT !redshift exceeds exit value
                else if (iexit == 2) then
                    zp1=abs(yo(1)/yinit(1))
                    dL=yo(10)*zp1*zp1
                    if (dL >= val_exit) EXIT !dL exceeds exit value
                else
                    if (yo(5) <= val_exit) EXIT !time precedes exit value
                end if
                si=so
                yi=yo
                dyi=dyo
            end if
        end do
! Find s=sf corresponding to exit value
        sf=zbrent(f,si,so,sacc)
! If zbrent goes wrong, fall back to trusty rtbis
        if (sf > so .or. sf < si) then
            ! print *, 'sf outside bounds: ', sf,si,so
            sf=rtbis(f,si,so,sacc)
        end if
! Find soln at sf by interpolating between yi and yo
        yf=ydout(dsi,si,sf,k,yi,yo)
    contains
        real(dp) function f(s)
            implicit none
            real(dp), intent(in) :: s
            real(dp), dimension(size(yinit)) :: yint
            real(dp) zint
            yint=ydout(dsi,si,s,k,yi,yo)
            if (iexit == 1) then
                zint=abs(yint(1)/yinit(1))-1._dp
                f=zint-val_exit
            else if (iexit == 2) then
                f=yint(10)-val_exit
            else
                f=yint(5)-val_exit
            end if
        end function f
    end subroutine rayshoot

    subroutine ode_null(s,y,dy)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The null geodesic equations as a first-order ODE solved    !
! simultaneously with the angular diameter distance D_A      !
! This routine takes as input: (1) the indepedent variable s !
! which, although is not explicit, is generically required   !
! by the ODE solver and (2) the dependent variable y at s    !
!                                                            !
!    s    affine parameter (independent variable)            !
!    y    (k^mu, x^mu, dDA/ds, DA); size(y)=10               !
!    dy   (dk^mu/ds, dx^mu/ds, d2DA/ds2, dDA/ds)             !
!                                                            !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        implicit none
        real(dp), intent(in) :: s
        real(dp), dimension(:), intent(in) :: y
        real(dp), dimension(size(y)), intent(out) :: dy
        real(dp), dimension(4) :: x,v
        real(dp), dimension(4,4) :: gam_ij
        real(dp), dimension(4,4,4) :: gam
        type(four_position) :: xc
        real(dp) :: gkk,rho
        integer :: i,j,k
        x=y(5:8)
        v=y(1:4)
        if (x(2) < 0.) then
            write(*,*) 'negative r coord: ', x(2)
            x(2)=abs(x(2))
            if (v(2) < 0.) v(2)=abs(v(2))
        end if
        xc=init_four_position(x)
        call christoffel(xc,gam)
        do k=1,4
            gam_ij=gam(k,:,:)
            gkk=dot_product(matmul(gam_ij,v),v)
            dy(k)=-gkk
        end do
        dy(5:8)=y(1:4)
! compute if solving for angular diameter distance
        if (size(y) == 10) then
            call density(xc,rho)
            dy(9)=-0.5_dp*rho*y(1)*y(1)
            dy(10)=y(9)
        end if
        call del_four_position(xc)
    end subroutine ode_null

    subroutine construct_ray(ti,obs_pos,theta_local_sky,phi_local_sky,pv,nv) !fix v3
        implicit none
        real(dp), intent(in) :: ti
        real(dp), dimension(3), intent(in) :: obs_pos
        real(dp), intent(in) :: theta_local_sky !radians
        real(dp), intent(in) :: phi_local_sky
        real(dp), dimension(4), intent(out) :: pv,nv
        real(dp), dimension(4) :: nvo
        real(dp), dimension(3) :: dv
        real(dp), dimension(4,4) :: g,Ec
        real(dp), parameter :: tol=1.e-8_dp
        real(dp) :: alpha,psi,thetac,k2
        integer :: i,j
        pv(1)=ti
        pv(2:4)=obs_pos
        call metric(pv,g)
        call tetrad(pv,Ec)
!   nv - null vector
!   dv - directional vector in local orthonormal frame
        call ang2vec(theta_local_sky,phi_local_sky,dv)
! Re-orient healpix coordinates so direction of north pole
! coincides with radial direction BV(2,:). MAKE SURE phi=PI/2
        ! thetac=pi-theta
        ! psi=thetac
        ! alpha=phi-0.5*PI
        ! call rotatex(psi,dv)
        ! call rotatez(alpha,dv)
        nvo(1)=-1._dp
        nvo(2)=dv(1)
        nvo(3)=dv(2)
        nvo(4)=dv(3)
        nv=matmul(Ec,nvo)
        ! k2=dot_product(matmul(g,nv),nv)
        ! print *, k2
! perturb if ray passes through coord centre
        if (abs(nv(3)) < tol .and. abs(nv(4)) < tol) then
            write(*,*) 'warning: ray crosses r=0'
            nv(3)=sign(tol,nv(3))
            nv(4)=sign(tol,nv(4))
! need to re-normalise it
            k2=0._dp
            do j=2,4
                do i=2,4
                    k2=k2+g(i,j)*nv(i)*nv(j)
                enddo
            enddo
            nv=nv/sqrt(abs(k2))
            nv(1)=-sqrt(abs(k2))
        end if
    end subroutine construct_ray

end module sznullgeo


! 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.
! Created: 08/02/2009

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

module WCLimits
   implicit none
   integer lmin, lmax
   integer mmin, mmax
   integer nmin, nmax
   integer Cjmax, Cqmax, Ckmax
end module WCLimits

program PsHMain
	implicit none

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

	real*8 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
	real*16, allocatable, dimension(:,:) :: PhiPhi, Phi2HPhi
	real*16 Alpha, Beta, Gamma
	logical ReadParamFile, ReadResult
	integer iargc, IsTriplet, Method, LowerEigen, UpperEigen, AllEnergies, EigenRoutine
	integer Optimize, EigenNum, Ordering, GradGrad, Iter, MaxIter, MaxIterOuter, qmax, pmax
	integer CalcPowerTableSize, NumUsed, i, j, k, n
	real*8 StartTime, EndTime, fa
	character *100 IOBuffer

	!call omp_set_num_threads(3)

	iread = 9
	iwrite = 10
	call GenFactorial(400)

	! 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.xml')
	endif

	!@TODO: Should probably check the output
	ReadResult = ReadParamFile(iread, Omega, Alpha, Beta, Gamma, qmax, Method, pmax, IsTriplet, LowerEigen, UpperEigen, &
								AllEnergies, Optimize, EigenNum, MaxIter, Ordering, EigenRoutine, GradGrad)

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

	NumTerms = CalcPowerTableSize(Omega)
	allocate(PhiPhi(NumTerms,NumTerms))
	allocate(Phi2HPhi(NumTerms,NumTerms))

	call WriteHeader(iwrite, Optimize, EigenNum, IsTriplet, Ordering, Method, Omega, Alpha, Beta, Gamma, NumTerms, GradGrad, EigenRoutine)

	if (Optimize == 1) then
		fa = optimizewavefn(MaxIter, Omega, NumTerms, qmax, pmax, IsTriplet, Ordering, Method, EigenRoutine, GradGrad, dble(Alpha), dble(Beta), dble(Gamma))
		call CalcMatrices(Omega, NumTerms, Alpha, Beta, Gamma, EigenNum, PhiPhi, Phi2HPhi, qmax, pmax, &
					IsTriplet, Ordering, Method, GradGrad)
	else
		! If we are not optimizing eigenvalues, we can still call the same function, which exits early with PhiPhi and Phi2HPhi filled.
		call CalcMatrices(Omega, NumTerms, Alpha, Beta, Gamma, EigenNum, PhiPhi, Phi2HPhi, qmax, pmax, &
					IsTriplet, Ordering, Method, GradGrad)
		write (*,*) fa
	endif

	call WriteData(iwrite, NumTerms, PhiPhi, Phi2HPhi)

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

	call CalcEigenvalues(iwrite, NumTerms, AllEnergies, PhiPhi, Phi2HPhi, LowerEigen, UpperEigen)

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

	! Clean up memory before exiting
	deallocate(PhiPhi, Phi2HPhi)

	! Close file handle
	close(iwrite)
stop
end

! Read the input parameters.
logical function ReadParamFile(iread, Omega, Alpha, Beta, Gamma, qmax, Method, pmax, IsTriplet, LowerEigen, UpperEigen, &
								AllEnergies, Optimize, EigenNum, MaxIter, Ordering, EigenRoutine, GradGrad)
	implicit none
	integer iread, Omega, qmax, Method, pmax, IsTriplet, LowerEigen, UpperEigen
	integer AllEnergies, Optimize, EigenNum, MaxIter, Ordering, EigenRoutine, GradGrad
	real*16 Alpha, Beta, Gamma

	read (iread,*) ! Description line
	read (iread,*) Omega
	read (iread,*) ! Description line
	read (iread,*) Alpha
	read (iread,*) Beta
	read (iread,*) Gamma
	read (iread,*) ! Description line
	read (iread,*) qmax
	read (iread,*) ! Description line
	read (iread,*) Method
	read (iread,*) ! Description line
	read (iread,*) pmax
	read (iread,*) ! Description line
	read (iread,*) IsTriplet
	read (iread,*) ! Description line
	read (iread,*) LowerEigen, UpperEigen
	read (iread,*) ! Description line
	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
	read (iread,*)
	read (iread,*) GradGrad

	close(iread)  ! We are done with this parameter file.

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

	ReadParamFile = .true.
	return
end

! Outputs header information to the output file and to the screen
subroutine WriteHeader(iwrite, Optimize, EigenNum, IsTriplet, Ordering, Method, Omega, Alpha, Beta, Gamma, NumTerms, GradGrad, EigenRoutine)
	implicit none
	integer iwrite, Optimize, EigenNum, IsTriplet, Ordering, Method, Omega, NumTerms, GradGrad, EigenRoutine
	real*16 Alpha, Beta, Gamma
	character (len=8) cdate
	character (len=8) ctime

	if (Optimize == 1) write (iwrite,*) 'Optimizing eigenvalue - not a valid XML file!', EigenNum

	write (iwrite,'(a)') '<?xml version="1.0" encoding="UTF-8"?>'
	write (iwrite,'(a)') "<psh_data>"
	write (iwrite,'(a)') "<header>"
	if (IsTriplet == 0) then
		if (GradGrad == 1) then
			write (*,*) "S-Wave Singlet Ps-H - Grad-Grad Formalism"
			write (iwrite,'(a)') "    <problem>S-Wave Singlet Ps-H - Grad-Grad Formalism</problem>"
		else
			write (*,*) "S-Wave Singlet Ps-H - Laplacian Formalism"
			write (iwrite,'(a)') "    <problem>S-Wave Singlet Ps-H - Laplacian Formalism</problem>"
		end if
	else
		if (GradGrad == 1) then
			write (*,*) "S-Wave Triplet Ps-H - Grad-Grad Formalism"
			write (iwrite,'(a)') "    <problem>S-Wave Triplet Ps-H - Grad-Grad Formalism</problem>"
		else
			write (*,*) "S-Wave Triplet Ps-H - Laplacian Formalism"
			write (iwrite,'(a)') "    <problem>S-Wave Triplet Ps-H - Laplacian Formalism</problem>"
		end if
	endif

	write (iwrite,'(a)') "    <lvalue>0</lvalue>"  ! Indicates S-wave
	if (IsTriplet == 0) then
		write (iwrite,'(a,i0,a)') "    <spin>Singlet</spin>"
	else
		write (iwrite,'(a,i0,a)') "    <spin>Triplet</spin>"
	end if

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

	if (GradGrad == 1) then
		write (iwrite,'(a)') "    <gradlapl>Gradient-Gradient</gradlapl>"
	else  ! Assuming Laplacian
		write (iwrite,'(a)') "    <gradlapl>Laplacian</gradlapl>"
	end if

	write (iwrite,'(a)') "    <formalism>1</formalism>"  ! Only one type that we can do for the S-wave

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

	write (*,*) 'Number of terms:', NumTerms
	write (*,*) 'Omega =', Omega
	write (iwrite,'(a,i0,a)') "    <omega>", Omega, "</omega>"
	write (iwrite,'(a,i0,a)') "    <numterms>", NumTerms, "</numterms>"
	write (iwrite,'(a)') "    <numsets>1</numsets>"  ! Can only have one set for the S-wave

	!write (iwrite,'(a)') "    <extraexp>false</extraexp>"  ! Not doing extra exponentials here
	write (iwrite,'(a)') "    <nonlinear>"
	write (iwrite,'(a,f12.10,a)') "        <alpha>", Alpha, "</alpha>"
	write (iwrite,'(a,f12.10,a)') "        <beta>", Beta, "</beta>"
	write (iwrite,'(a,f12.10,a)') "        <gamma>", Gamma, "</gamma>"
	write (iwrite,'(a)') "    </nonlinear>"

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

	! Note that this is not Y2K compliant.
	call date(cdate)
	call time(ctime)
	write (iwrite,'(5a)') "    <datetime>", cdate, " ", ctime, "</datetime>"

	write (iwrite,'(a)') "</header>"

	return
end

! Outputs only the matrix elements (before division of Phi2HPhi by 2)
subroutine WriteData(iwrite, NumTerms, PhiPhi, Phi2HPhi)
	implicit none
	integer iwrite, NumTerms, i, j
	real*16, dimension(NumTerms,NumTerms) :: PhiPhi, Phi2HPhi

	write (iwrite,'(a)') "<data>"
	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,"(a,i7,i7,d38.30,d38.30)") '    ', i, j, PhiPhi(i,j), Phi2HPhi(i,j)
		enddo
	enddo
	write (iwrite,'(a)') "</data>"

	return
end

! Solves the generalized eigenvalue problem and outputs results
subroutine CalcEigenvalues(iwrite, NumTerms, AllEnergies, PhiPhi, Phi2HPhi, LowerEigen, UpperEigen)
	implicit none
	integer iwrite, NumTerms, AllEnergies, StartEnergy, LowerEigen, UpperEigen
	real*16, dimension(NumTerms,NumTerms) :: PhiPhi, Phi2HPhi
	real*8, allocatable, dimension(:,:) :: PhiPhi8, Phi2HPhi8
	real*8, allocatable, dimension(:) :: Energies, Workspace
	integer i, j, Info

	allocate(PhiPhi8(NumTerms,NumTerms))
	allocate(Phi2HPhi8(NumTerms,NumTerms))
	allocate(Energies(NumTerms))
	allocate(Workspace(3*NumTerms-1))

	write (iwrite,'(a)') '<energies>'

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

	if (UpperEigen > NumTerms) UpperEigen = NumTerms

	do j = StartEnergy, NumTerms, 1
	!do j = 1, 1, 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 (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,"(a,i4)",advance='no') '    ', j
			do i = LowerEigen, UpperEigen, 1
				write (iwrite,"(a,d21.14)",advance='no') ', ', Energies(i)
			enddo
			write (iwrite,'(a)') ' '  ! 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

	write (iwrite,'(a)') '</energies>'

	deallocate(PhiPhi8, Phi2HPhi8)
	deallocate(Energies, Workspace)

	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.

	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)
	!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

	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
										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

						   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 (11,'(i4,a,6i4)') INX, ": ", I1, I2, I12, I3, I13, I23
	70                  CONTINUE
	69                CONTINUE
	68              CONTINUE
	67            CONTINUE
	66          CONTINUE
	65        CONTINUE
	endif

	return
end

! I am using the same numbering as in Dr. Quintanilla's table (Tablecoeff.pdf).
!  This was modified to differentiate between the alpha, beta and gamma of f_i and f_j,
!  and the table has been changed to reflect this.
subroutine GenCoeffTableGradGrad(CoeffTable, PowerTablei, i, PowerTablej, j, NumTerms, Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj)
	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
	real*8 ScatteringVal
	integer ki, li, mi, ni, pi, qi, kj, lj, mj, nj, pj, qj

	! 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)

!	if (IsScattering == 0) ScatteringVal = 0.0q0
!	if (IsScattering == 1) ScatteringVal = 1.5q0
	ScatteringVal = 0.0q0

	! These coefficients are taken from equation (3.25) of Armour and Humberston's article,
	!  with one minor exception: we have included gamma in the derivation.  Gamma = Beta in the case
	!  of Ps-He scattering but does not for Ps-H.
	CoeffTable(1) =   Alphai * Alphaj + Betai * Betaj + Gammai * Gammaj + ScatteringVal
	CoeffTable(2) =   2.0q0 - (Alphaj*ki + Alphai*kj) - 0.5q0 * (Alphaj*mi + Alphai*mj) - 0.5q0 * (Alphaj*pi + Alphai*pj)
	CoeffTable(3) =  -2.0q0 - (Betaj*li + Betai*lj) - 0.5q0 * (Betaj*mi + Betai*mj) - 0.5q0 * (Betaj*qi + Betai*qj)
	CoeffTable(4) =  -2.0q0
	CoeffTable(5) =  -2.0q0 - (Gammaj*ni + Gammai*nj) - 0.5q0 * (Gammaj*qi + Gammai*qj) - 0.5q0 * (Gammaj*pi + Gammai*pj)
	CoeffTable(6) =  -2.0q0
	CoeffTable(7) =   2.0q0
	CoeffTable(8) =   0.5q0 * (ki*mj + kj*mi + ki*pj + kj*pi) + ki*kj
	CoeffTable(9) =   0.5q0 * (li*mj + lj*mi + li*qj + lj*qi) + li*lj
	CoeffTable(10) =  0.5q0 * (ki*mj + kj*mi + li*mj + lj*mi + mi*pj + mj*pi + mi*qj + mj*qi) + 2.0q0*mi*mj
	CoeffTable(11) =  0.5q0 * (ni*qj + nj*qi + ni*pj + nj*pi) + ni*nj
	CoeffTable(12) =  0.5q0 * (ki*pj + kj*pi + ni*pj + nj*pi + mi*pj + mj*pi + pi*qj + pj*qi) + 2.0q0*pi*pj
	CoeffTable(13) =  0.5q0 * (li*qj + lj*qi + ni*qj + nj*qi + mi*qj + mj*qi + pi*qj + pj*qi) + 2.0q0*qi*qj
	CoeffTable(14) = -0.5q0 * (Alphaj*mi + Alphai*mj)
	CoeffTable(15) = -0.5q0 * (Betaj*mi + Betai*mj)
	CoeffTable(16) =  0.5q0 * (Alphaj*mi + Alphai*mj)
	CoeffTable(17) = -0.5q0 * (ki*mj + kj*mi)
	CoeffTable(18) =  0.5q0 * (Betaj * mi + Betai*mj)
	CoeffTable(19) = -0.5q0 * (li*mj + lj*mi)
	CoeffTable(20) = -0.5q0 * (Alphaj*pi + Alphai*pj)
	CoeffTable(21) = -0.5q0 * (Gammaj*pi + Gammai*pj)
	CoeffTable(22) =  0.5q0 * (Alphaj*pi + Alphai*pj)
	CoeffTable(23) = -0.5q0 * (ki*pj + kj*pi)
	CoeffTable(24) =  0.5q0 * (Gammaj*pi + Gammai*pj)
	CoeffTable(25) = -0.5q0 * (ni*pj + nj*pi)
	CoeffTable(26) = -0.5q0 * (Gammaj*qi + Gammai*qj)
	CoeffTable(27) = -0.5q0 * (Betaj*qi + Betai*qj)
	CoeffTable(28) =  0.5q0 * (Gammaj*qi + Gammai*qj)
	CoeffTable(29) = -0.5q0 * (ni*qj + nj*qi)
	CoeffTable(30) =  0.5q0 * (Betaj*qi + Betai*qj)
	CoeffTable(31) = -0.5q0 * (li*qj + lj*qi)
	CoeffTable(32) = -0.5q0 * (pi*qj + pj*qi)
	CoeffTable(33) = -0.5q0 * (mi*pj + mj*pi)
	CoeffTable(34) = -0.5q0 * (mi*qj + mj*qi)

	return
end

! Note that the naming is a little different here.  I used rPowerTable here as the parameter name but
!  use rPowers elsewhere.
subroutine GenRPowerTableGradGrad(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,-1, 0, 0, 0, 0, 0,-2, 0, 0, 0, 0, 0, 1, 0,-1,-2, 2, 2, 1, 0,-1,-2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, &  ! r1
				   0, 0,-1, 0, 0, 0, 0, 0,-2, 0, 0, 0, 0, 0, 1, 2, 2,-1,-2, 0, 0, 0, 0, 0, 0, 0, 1, 2, 2,-1,-2, 0, 0, 0, &  ! r2
				   0, 0, 0,-1, 0, 0, 0, 0, 0,-2, 0, 0, 0,-2,-2,-2,-2,-2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2,-2,-2, &  ! r12
				   0, 0, 0, 0,-1, 0, 0, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 2,-1,-2, 1, 0,-1,-2, 2, 2, 0, 0, 0, &  ! r3
				   0, 0, 0, 0, 0,-1, 0, 0, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0,-2,-2,-2,-2,-2,-2, 0, 0, 0, 0, 0, 0,-2,-2, 2, &  ! r13
				   0, 0, 0, 0, 0, 0,-1, 0, 0, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-2,-2,-2,-2,-2,-2, 2,-2 /  ! r23

	! 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

! This calculates the Hamiltonian directly with the Laplacians, as in Drake and Yan's 1997 paper.
subroutine GenCoeffTableLaplacian(CoeffTable, PowerTablei, i, PowerTablej, j, NumTerms, Alphai, Alphaj, Betai, Betaj, &
						 Gammai, Gammaj)
	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

	l1r = 0; l2r = 0; l3r = 0;  ! Always 0 for the S-wave

	! 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)

	! These coefficients are taken from equation (3.25) of Armour and Humberston's article,
	!  with one minor exception: we have included gamma in the derivation.  Gamma = Beta in the case
	!  of Ps-He scattering but does not for Ps-H.
	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

subroutine GenRPowerTableLaplacian(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

! Sets all WMatrix elements equal to 0.
subroutine ClearWCMatrices(WMatrix, CMatrix)
	use WCLimits
	implicit none
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	real*16, dimension(-2:Cjmax, 0:Cqmax, 0:Ckmax) :: CMatrix

	WMatrix = 0.0q0  ! Just a chosen value to show whether this has been used.
	CMatrix = 0.0q0
	return
end

! This precalculates the W matrices, since the W function is computationally expensive.
subroutine CalcWCMatrices(Omega, qmax, WMatrix, CMatrix, Alpha, Beta, Gamma, pmax)
	use WCLimits
	implicit none
	integer Omega, qmax
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	real*16, dimension(-2:Cjmax, 0:Cqmax, 0:Ckmax) :: CMatrix
	real*16 Alpha, Beta, Gamma
	integer pmax
	real*16 W, C
	integer j, k, l, m, n, q

	!$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 (*,*)

	do j = -2, Cjmax, 1
		do q = 0, Cqmax, 1
			do k = 0, Ckmax, 1
				if (CMatrix(j, q, k) /= 0.0q0) then
					CMatrix(j, q, k) = C(j, q, k)
				end if
			end do
		end do
	end do

	return
end

!@TODO: Rename this to something more descriptive.
subroutine CalcMatricesSub(RunCalc, CoeffTable, rPowers, PowerTablei, PowerTablej, WMatrix, CMatrix, PhiPhi, Phi2HPhi, NumTerms, &
						Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, qmax, pmax, IsTriplet, Method, GradGrad)
	use WCLimits
	implicit none
	real*16, dimension(34) :: CoeffTable
	integer, dimension(34,6) :: rPowers
	integer, dimension(NumTerms,6) :: PowerTablei, PowerTablej
	real*16, dimension(lmin:lmax, mmin:mmax, nmin:nmax, 6) :: WMatrix
	real*16, dimension(-2:Cjmax, 0:Cqmax, 0:Ckmax) :: CMatrix
	real*16, dimension(NumTerms,NumTerms) :: PhiPhi, Phi2HPhi
	integer qmax, pmax, NumTerms, Method, GradGrad
	logical RunCalc
	real*16 Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj
	real*16 HylleraasIntegral
	real*16 Sum
	real*8 PI
	integer i, j, n, IsTriplet
	real*16 RemoveMe
	real*16 PiHalf
	integer WUsed, WUnused, l, m
	! Calculated in Mathematica
	PiHalf = 0.1591549430918953357688837633725143620345q0

	!$omp parallel do shared(NumTerms) private(j,Sum,RemoveMe,CoeffTable,rPowers) 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
			if (GradGrad == 0) then  ! Use grad-grad formalism
				call GenCoeffTableGradGrad(CoeffTable, PowerTablei, i, PowerTablej, j, NumTerms, &
									Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj)
				call GenRPowerTableGradGrad(rPowers, PowerTablei, i, PowerTablej, j, NumTerms)
			else  ! Use Laplacian formalism
				call GenCoeffTableLaplacian(CoeffTable, PowerTablei, i, PowerTablej, j, NumTerms, Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj)
				call GenRPowerTableLaplacian(rPowers, PowerTablei, i, PowerTablej, j, NumTerms)
			end if

			do n = 1, 34, 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.

					RemoveMe = HylleraasIntegral(RunCalc, rPowers(n,1), rPowers(n,2), rPowers(n,4), rPowers(n,3), rPowers(n,6), &
												  rPowers(n,5), Alphai+Alphaj, Betai+Betaj, Gammai+Gammaj, qmax, pmax, Method, WMatrix, CMatrix)
					Sum = Sum + RemoveMe * CoeffTable(n)
				endif
			enddo

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

			! Do the PhiPhi inner product
			RemoveMe = HylleraasIntegral(RunCalc, 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, qmax, pmax, Method, WMatrix, CMatrix)
			if (IsTriplet == 0) then
				PhiPhi(i,j) = PhiPhi(i,j) + RemoveMe * PiHalf
			else
				PhiPhi(i,j) = PhiPhi(i,j) - RemoveMe * PiHalf
			endif
		enddo
	enddo

	write (*,*)
end

! Called by optimizewavefn in Minimize.c
subroutine calcmatriceswrapper(Omega, NumTerms, qmax, pmax, IsTriplet, Ordering, Method, EigenRoutine, GradGrad, Alpha, Beta, Gamma, Energy) bind(C)
	implicit none
	real*16, allocatable, dimension(:,:) :: PhiPhi, Phi2HPhi
	real*8, allocatable, dimension(:,:) :: PhiPhi8, Phi2HPhi8
	real*8, allocatable, dimension(:) :: Energies, Workspace
	integer Omega, NumTerms, qmax, pmax, IsTriplet, Ordering, Method, EigenRoutine, GradGrad, Info
	integer, save :: Iter = 1
	real*8 Alpha, Beta, Gamma
	real*8 Energy

	allocate(PhiPhi(NumTerms,NumTerms))
	allocate(Phi2HPhi(NumTerms,NumTerms))
	allocate(Energies(NumTerms))
	allocate(Workspace(3*NumTerms-1))  ! Not really needed for Newdsygv?
	Energies = 0.0q0

	call CalcMatrices(Omega, NumTerms, real(Alpha,16), real(Beta,16), real(Gamma,16), 1, PhiPhi, Phi2HPhi, &
					qmax, pmax, IsTriplet, Ordering, Method, GradGrad)

	Phi2HPhi = Phi2HPhi / 2
	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)
		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)
	Iter = Iter + 1
end

! Calculates the derivative of the energy function.  If the Deriv parameter = 0, then it exits early with
!  PhiPhi and Phi2HPhi filled.
subroutine CalcMatrices(Omega, NumTerms, Alpha, Beta, Gamma, EigenNum, PhiPhi, Phi2HPhi, qmax, pmax, IsTriplet, Ordering, Method, GradGrad)
	use WCLimits
	!use nag_nsym_gen_eig
	implicit none
	real*16 Alpha, Beta, Gamma, Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj
	real*8 e
	integer, allocatable, dimension(:,:) :: PowerTablei, PowerTablej, rPowers  ! 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, qmax, pmax, IsTriplet, Method, GradGrad, Ordering, i, j, n, Info
	real*16, allocatable, dimension(:) :: CoeffTable
	real*16, dimension(NumTerms,NumTerms) :: PhiPhi, Phi2HPhi
	real*16, allocatable, dimension(:,:,:,:) :: WMatrix
	real*16, allocatable, dimension(:,:,:) :: CMatrix
	real*16 PhiHPhiSum, PhiPhiSum, Norm

	allocate(PowerTablei(NumTerms, 6))
	call GenOmegaPowerTable(Omega, PowerTablei, NumTerms, Ordering)
	allocate(PowerTablej(NumTerms, 6))
	call GenOmegaPowerTable(Omega, PowerTablej, NumTerms, Ordering)
	allocate(CoeffTable(34))
	allocate(rPowers(34,6))

	! Set this matrix equal to 0 because of the Phi2HPhi(i,j) = Phi2HPhi(i,j) + Sum line in CalcMatricesSub
	!  (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+1) + 2*qmax + 4;
	mmin = 0;  mmax = 2*(Omega+1) + 3;
	nmin = -1 - 2*qmax;  nmax = 2*(Omega+1) + 2;
	allocate(WMatrix(lmin:lmax, mmin:mmax, nmin:nmax, 6))
	Cjmax = 2*Omega+4;  Cqmax = qmax;  Ckmax = 2*Omega+5;
	allocate(CMatrix(-2:Cjmax, 0:Cqmax, 0:Ckmax))

	if (Method == 0 .or. Method == 1) then
		write (*,*) "Precomputing W matrix"
		call ClearWCMatrices(WMatrix, CMatrix)
		! First call it with RunCalc = false to determine what W functions to calculate.
		call CalcMatricesSub(.false., CoeffTable, rPowers, PowerTablei, PowerTablej, WMatrix, CMatrix, PhiPhi, Phi2HPhi, NumTerms, &
					Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, qmax, pmax, IsTriplet, Method, GradGrad)
		! Then precalculate all W functions that are used.
		call CalcWCMatrices(Omega+1, qmax, WMatrix, CMatrix, Alphai+Alphaj, Betai+Betaj, Gammai+Gammaj, pmax)
		write (*,*) "Finished precomputing W matrix"
	else  ! Method == 2 (recursion relations)
		write (*,*) "Precomputing gamma functions"
		call PreCalcGamma(real(Alphai+Alphaj,16), real(Betai+Betaj,16), real(Gammai+Gammaj,16), PreCalcGammaSize(Omega))
		write (*,*) "Finished precomputing gamma functions"
	end if

	! This subroutine call calculates the PhiPhi and Phi2HPhi matrices for the direct integrals.
	call CalcMatricesSub(.true., CoeffTable, rPowers, PowerTablei, PowerTablej, WMatrix, CMatrix, PhiPhi, Phi2HPhi, NumTerms, &
						Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, qmax, pmax, IsTriplet, Method, GradGrad)
	!goto 100
	if (IsTriplet == 1) then  ! Only do this for the triplet case.
		PhiPhi = -PhiPhi
		Phi2HPhi = -Phi2HPhi
	endif

	! Now we have to do the same thing for the exchange operator, P_23.
	call Permute(PowerTablej, NumTerms, Alphai, Alphaj, Alpha, Betai, Betaj, Beta, Gammai, Gammaj, Gamma)

	! We have to recalculate the W matrices again, since we had the swaps.  The limits are still the same as above,
	!  though, since the nonlinear parameters do not affect the limits.
	if (Method == 0 .or. Method == 1) then
		write (*,*) "Precomputing W matrix"
		call ClearWCMatrices(WMatrix, CMatrix)
		call CalcMatricesSub(.false., CoeffTable, rPowers, PowerTablei, PowerTablej, WMatrix, CMatrix, PhiPhi, Phi2HPhi, NumTerms, &
							Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, qmax, pmax, IsTriplet, Method, GradGrad)
		call CalcWCMatrices(Omega+1, qmax, WMatrix, CMatrix, Alphai+Alphaj, Betai+Betaj, Gammai+Gammaj, pmax)
		write (*,*) "Finished precomputing W matrix"
	else  ! Method == 2
		write (*,*) "Precomputing gamma functions"
		call PreCalcGamma(real(Alphai+Alphaj,16), real(Betai+Betaj,16), real(Gammai+Gammaj,16), PreCalcGammaSize(Omega))
		write (*,*) "Finished precomputing gamma functions"
	end if

	! Calculate the matrix elements for the exchanged terms, and add them to the direct terms.
	call CalcMatricesSub(.true., CoeffTable, rPowers, PowerTablei, PowerTablej, WMatrix, CMatrix, PhiPhi, Phi2HPhi, NumTerms, &
						Alphai, Alphaj, Betai, Betaj, Gammai, Gammaj, qmax, pmax, IsTriplet, Method, GradGrad)

	! Clean up memory before exiting
100	deallocate(WMatrix, CMatrix)
	deallocate(rPowers, CoeffTable)
	deallocate(PowerTablei, PowerTablej)

	return
end

! We operate it on f_j by switching the
!  2<->3 powers in PowerTablej and recalculating, along with beta and gamma.
subroutine Permute(PowerTablej, NumTerms, Alphai, Alphaj, Alpha, Betai, Betaj, Beta, Gammai, Gammaj, Gamma)
	implicit none
	integer NumTerms, n, TempJ
	integer, dimension(NumTerms,6) :: PowerTablej
	real*16 Alpha, Alphai, Alphaj, Betai, Betaj, Beta, Gammai, Gammaj, Gamma

	do n = 1, NumTerms, 1
		! This exchanges r2 and r3.
		TempJ = PowerTablej(n,2)
		PowerTablej(n,2) = PowerTablej(n,4)  ! l with n
		PowerTablej(n,4) = TempJ
		! This exchanges r12 and r13 (r31).
		TempJ = PowerTablej(n,3)
		PowerTablej(n,3) = PowerTablej(n,5)  ! m with p
		PowerTablej(n,5) = TempJ
	enddo

	Alphai = Alpha; Alphaj = Alpha; Betaj = Gamma; Betai = Beta; Gammaj = Beta; Gammai = Gamma;
	return
end


C  PROGRAM MEM
C
C	PERFORMS MAXIMUM ENTROPY DECONVOLUTION.
C
C
C	VERSION :	NEW		JANUARY 1986
C
c                B      ported 7,1998  J. Lorre
C	REVISION A:	ADDED DIRECT CONVOLUTION, FIX BUGS
C			KFE	FEBRUARY 1986
C
C
C	ORIGINAL PROGRAMMER :		K. F. EVANS
C
C
	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44

	INCLUDE 'mem.inc'

	INTEGER	LOG2, SCRNUM
	REAL	MAXFORMAT
	CHARACTER*32 FORMAT
	CHARACTER*40 STRING
	LOGICAL	XVPTST
        integer junk1,junk2

	DATA	DATA/1/, PSF/2/, DEFAULT/3/, OUT/4/, XFER/5/, TMPFFT/6/,
     +      DEF/7/, CURRENT/8/, GRDE/9/, CNVSTP/9/, RESID/10/, STEP/11/

C ******************************** START OF EXECUTABLE CODE

C		GET THE INPUT PARAMETERS
	CALL XVP ('MAXITER', MAXITER, COUNT)
	CALL XVP ('RMSERROR', TARGETRMS, COUNT)
	CALL XVP ('MAXCRIT', MAXCRIT, COUNT)

	RESTART = XVPTST ('RESTART')

C		OPEN THE CONVOLVED (BLURRED) IMAGE
	CALL XVUNIT (UNIT(DATA), 'INP', 1, STATUS,' ')
	CALL XVOPEN (UNIT(DATA), STATUS, 'IO_ACT', 'SA',
     +		'OPEN_ACT', 'SA', 'U_FORMAT', 'REAL',' ')
	CALL XVSIZE (SL,SS,NL,NS,junk1,junk2)
	IF (NL .GT. 4096 .OR. NS .GT. 4096) THEN
	    CALL xvmessage ('Maximum image size exceeded.',' ')
	    CALL ABEND
	ENDIF
	NPIXELS = FLOAT(NL*NS)
	CALL XVGET (UNIT(DATA), STATUS, 'FORMAT', FORMAT,' ')
	IF (FORMAT(1:4) .EQ. 'HALF' .OR. FORMAT(1:4) .EQ. 'WORD') THEN
	    MAXFORMAT = 32767.0
	ELSE IF (FORMAT(1:4) .EQ. 'FULL') THEN
	    MAXFORMAT = 2147483647.0
	ELSE IF (FORMAT(1:4) .EQ. 'BYTE') THEN
	    MAXFORMAT = 255.0
	ENDIF

C		OPEN THE POINT SPREAD FUNCTION (PSF)
	CALL XVUNIT (UNIT(PSF), 'INP', 2, STATUS,' ')
	CALL XVOPEN (UNIT(PSF), STATUS, 'IO_ACT', 'SA', 'OPEN_ACT', 'SA',
     +		'U_FORMAT', 'REAL',' ')
	CALL XVGET (UNIT(PSF), STATUS, 'NL',NLPSF, 'NS',NSPSF,' ')

	IF (NLPSF .LE. 16 .AND. NSPSF .LE. 16)  THEN
	    SMALLPSF = .TRUE.
	ELSE
	    SMALLPSF = .FALSE.
	ENDIF

C		CALCULATE THE SIZE NEEDED FOR THE FFT
C		    MUST BE BIG ENOUGH SO THAT THE PSF WON'T WRAP AROUND
	NLFFT = 2**( LOG2(NL+NLPSF-1) + 1 )
	NSFFT = 2**( LOG2(NS+NSPSF-1) + 1 )

C		CREATE AND OPEN THE SCRATCH FILES
	SCRNUM = 0
	IF (.NOT. SMALLPSF) THEN
	    CALL OPENSCRATCH (UNIT(XFER), 'MEM1',
     +						SCRNUM,	NLFFT, NSFFT)
	    CALL OPENSCRATCH (UNIT(TMPFFT), 'MEM2',
     +						SCRNUM, NLFFT, NSFFT)
	ENDIF
	CALL OPENSCRATCH (UNIT(DEF), 'MEM3',
     +						SCRNUM, NL, NS)
	CALL OPENSCRATCH (UNIT(GRDE), 'MEM4',
     +						SCRNUM, NL, NS)
	CALL OPENSCRATCH (UNIT(RESID), 'MEM5',
     +						SCRNUM, NL, NS)
	CALL OPENSCRATCH (UNIT(STEP), 'MEM6',
     +						SCRNUM, NL, NS)
	CALL OPENSCRATCH (UNIT(CURRENT), 'MEM7',
     +						SCRNUM, NL, NS)

	IF (SMALLPSF) THEN
	    CALL READPSF
	ELSE
C		MAKE THE TRANSFER FUNCTION FROM THE PSF
	    CALL MAKEXFER
	ENDIF
	CALL XVCLOSE (UNIT(PSF), STATUS,' ')

C		COPY OR MAKE THE DEFAULT IMAGE
	CALL MAKEDEFAULT

	IF (RESTART) THEN
C		COPY THE OLD OUTPUT INTO THE CURRENT IMAGE SCRATCH
	    CALL XVUNIT( UNIT(OUT), 'OUT',1, STATUS,' ')
	    CALL XVOPEN( UNIT(OUT), STATUS, 'OP', 'READ',
     +			'OPEN_ACT', 'SA', 'IO_ACT', 'SA',
     +			'U_FORMAT', 'REAL',' ')
	    IMAGEMIN = 1.0E20
	    DO LINE = 1, NL
		CALL XVREAD(UNIT(OUT), IMAGE(1,CURRENT), STATUS, 'LINE',LINE,
     +                       ' ')
		DO SAMP = 1, NS
		    IMAGE(SAMP,CURRENT) = MAX( IMAGE(SAMP,CURRENT), 1.0E-8)
		    IMAGEMIN = MIN (IMAGEMIN, IMAGE(SAMP,CURRENT) )
		ENDDO
		CALL XVWRIT (UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +							'LINE',LINE,' ')
	    ENDDO
	    CALL XVCLOSE (UNIT(OUT), STATUS,' ')

	ELSE
C		COPY THE DEFAULT INTO THE CURRENT IMAGE TO START WITH
	    IMAGEMIN = 1.0E20
	    DO LINE = 1, NL
 		CALL XVREAD(UNIT(DEF), IMAGE(1,CURRENT), STATUS, 'LINE',LINE,
     +                       ' ')
		DO SAMP = 1, NS
		    IMAGEMIN = MIN (IMAGEMIN, IMAGE(SAMP,CURRENT) )
		ENDDO
		CALL XVWRIT (UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +					'LINE',LINE,' ')
	    ENDDO
	ENDIF

C		MAKE THE STARTING RESIDUALS FROM THE CURRENT IMAGE AND THE DATA
	CALL MAKEFIRSTRESID
	CALL XVCLOSE (UNIT(DATA), STATUS,' ')

	TARGETERROR = NPIXELS* TARGETRMS**2
	TOL = 0.10
	PSFVOLUME = 1.0
	MAXSTEPLEN = 2.0
	ITER = 0

C		CALCULATE THE STARTING ALPHA
	RMSERROR = SQRT(ERROR/NPIXELS)
	CALL xvmessage (' ',' ')
	WRITE (STRING,103) 'Starting RMS Error : ', RMSERROR
103	FORMAT (A,F12.4)
	CALL xvmessage (STRING,' ')

	CALL CONVIMAGE (RESID, GRDE, .TRUE.)
	CALL FIRSTALPHA
	IF (RESTART)  CALL UPDATEALPHA
C	TYPE *,'Starting alpha : ',ALPHA

	CALL xvmessage (' ',' ')

C		* * *	START OF MEM ITERATIONS   * * *

100	CONTINUE

	    ITER = ITER + 1

	    CALL CALCSTEP

	    CALL CONVIMAGE (STEP, CNVSTP, .FALSE.)
	    CALL CALCSTEPLEN

	    CALL TAKESTEP
	    CALL MAKENEWRESID
	    CALL CONVIMAGE (RESID, GRDE, .TRUE.)

	    CALL UPDATEALPHA

	    CALL TERMOUTPUT

	IF ( ITER .LT. MAXITER      .AND.
     +	     ((SOLUCRIT - MAXCRIT)/MAXCRIT .GT. TOL  .OR.
     +	      ABS((RMSERROR-TARGETRMS)/TARGETRMS) .GT. TOL) )  GOTO 100

	IF (  ((SOLUCRIT - MAXCRIT)/MAXCRIT .LE. TOL)  .AND.
     +	      (ABS((RMSERROR-TARGETRMS)/TARGETRMS) .LE. TOL) )  THEN
	    CALL xvmessage (' ',' ')
	    CALL xvmessage ('      * * *  CONVERGENCE ACHIEVED  * * *  '
     +				,' ')
	ENDIF

C		* * *	END OF MEM ITERATIONS   * * *

C		COPY CURRENT IMAGE SCRATCH INTO OUTPUT MEM IMAGE
	CALL XVUNIT( UNIT(OUT), 'OUT',1, STATUS,' ')
	CALL XVOPEN( UNIT(OUT), STATUS, 'OP', 'WRITE',
     +		'U_NL', NL,  'U_NS', NS,
     +		'OPEN_ACT', 'SA', 'IO_ACT', 'SA',
     +		'U_FORMAT', 'REAL', 'O_FORMAT',FORMAT,' ')

	DO LINE = 1, NL
	    CALL XVREAD(UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +			 'LINE',LINE, ' ')
	    IF (FORMAT(1:4) .NE. 'REAL') THEN
		DO SAMP = 1, NS
		    IMAGE(SAMP,CURRENT) =
     +			   MIN( IMAGE(SAMP,CURRENT) + 0.5, MAXFORMAT)
		ENDDO
	    ENDIF
	    CALL XVWRIT (UNIT(OUT), IMAGE(1,CURRENT), STATUS,
     +			 'LINE',LINE,' ')
	ENDDO
	CALL XVCLOSE (UNIT(OUT), STATUS,' ')

C		CLOSE AND DELETE SCRATCH FILES
	IF (.NOT. SMALLPSF) THEN
	    CALL XVCLOSE (UNIT(TMPFFT), STATUS,'CLOS_ACT','DELETE',' ')
	    CALL XVCLOSE (UNIT(XFER), STATUS, 'CLOS_ACT','DELETE',' ')
	ENDIF
	CALL XVCLOSE (UNIT(GRDE), STATUS, 'CLOS_ACT','DELETE',' ')
	CALL XVCLOSE (UNIT(CURRENT), STATUS, 'CLOS_ACT','DELETE',' ')
	CALL XVCLOSE (UNIT(DEF), STATUS, 'CLOS_ACT','DELETE',' ')
	CALL XVCLOSE (UNIT(RESID), STATUS, 'CLOS_ACT','DELETE',' ')
	CALL XVCLOSE (UNIT(STEP), STATUS, 'CLOS_ACT','DELETE',' ')

	RETURN
	END

	SUBROUTINE OPENSCRATCH (UNIT, NAME, SCRNUM, NL, NS)
C
C	CREATES AND OPENS A REAL SCRATCH FILE WITH NAME (NAME)
C	    OF SIZE NL BY NS AND RETURNS THE UNIT NUMBER
C
	IMPLICIT NONE
	INTEGER	UNIT, NL, NS
	CHARACTER*32 NAME
	INTEGER	STATUS, SCRNUM

	SCRNUM = SCRNUM + 1
	CALL XVUNIT (UNIT,'   ',SCRNUM,  STATUS, 'U_NAME',NAME,' ')
	CALL XVOPEN (UNIT, STATUS, 'OP','WRITE',
     +				'U_NL',NL, 'U_NS',NS,
     +				'O_FORMAT','REAL',
     +				'COND','LABELS', 'OPEN_ACT','SA',' ')
	CALL XVCLOSE (UNIT, STATUS,' ')
	CALL XVUNIT (UNIT,'   ',SCRNUM,  STATUS, 'U_NAME',NAME,' ')
	CALL XVOPEN (UNIT, STATUS, 'OP','UPDATE',
     +			'U_NL',NL, 'U_NS',NS,
     +			'I_FORMAT','REAL', 'U_FORMAT', 'REAL',
     +			'O_FORMAT','REAL',
     +			'IO_ACT', 'SA', 'OPEN_ACT', 'SA',' ')

	RETURN
	END

	SUBROUTINE MAKEDEFAULT
	INCLUDE 'mem.inc'
	REAL	DATAFLUX, AVGLEVEL
	INTEGER	INPCOUNT
	CHARACTER*132	INPFILES(3)

C		OPEN AND COPY THE DEFAULT IMAGE IF THERE IS ONE
	CALL XVP ('INP', INPFILES, INPCOUNT)
	IF (INPCOUNT .EQ. 3) THEN
	    DEFFLAG = .TRUE.
	ELSE
	    DEFFLAG = .FALSE.
	ENDIF

	IF (DEFFLAG) THEN
	    CALL XVUNIT (UNIT(DEFAULT), 'INP', 3, STATUS,' ')
	    CALL XVOPEN (UNIT(DEFAULT), STATUS, 'IO_ACT', 'SA',
     +		'OPEN_ACT', 'SA', 'U_FORMAT', 'REAL',' ')
	    DO LINE = 1, NL
		CALL XVREAD(UNIT(DEFAULT), IMAGE(1,DEF), STATUS,
     +						 'LINE',LINE,' ')
		DO SAMP = 1, NS
		    IMAGE(SAMP,DEF) = MAX( IMAGE(SAMP,DEF), 1.0E-8 )
		ENDDO
		CALL XVWRIT (UNIT(DEF), IMAGE(1,DEF), STATUS,
     +						 'LINE',LINE,' ')
	    ENDDO
	    CALL XVCLOSE (UNIT(DEFAULT), STATUS,' ')
	ELSE
	    DATAFLUX = 0.0
	    DO LINE = 1, NL
		CALL XVREAD(UNIT(DATA), IMAGE(1,DATA), STATUS,
     +					'LINE',LINE+SL-1, 'SAMP',SS,' ')
		DO SAMP = 1, NS
		    DATAFLUX = DATAFLUX + IMAGE(SAMP,DATA)
		ENDDO
	    ENDDO
	    AVGLEVEL = DATAFLUX/FLOAT(NL*NS)
	    DO SAMP = 1, NS
		IMAGE(SAMP,DEF) = AVGLEVEL
	    ENDDO
	    DO LINE = 1, NL
		CALL XVWRIT (UNIT(DEF), IMAGE(1,DEF), STATUS,
     +						 'LINE',LINE,' ')
	    ENDDO
	ENDIF

	RETURN
	END

	SUBROUTINE MAKEFIRSTRESID
	INCLUDE 'mem.inc'

C		CONVOLVE THE IMAGE WITH THE PSF AND SUBTRACT THE DATA
C		    IN ORDER TO MAKE THE STARTING RESIDUALS
	CALL CONVIMAGE (CURRENT, RESID, .FALSE.)
	ERROR = 0.0
	DO LINE = 1, NL
	    CALL XVREAD(UNIT(DATA), IMAGE(1,DATA), STATUS,
     +				'LINE',LINE+SL-1, 'SAMP',SS,' ')
	    CALL XVREAD(UNIT(RESID), IMAGE(1,RESID), STATUS,
     +				 'LINE',LINE,' ')
	    DO SAMP = 1, NS
		IMAGE(SAMP,RESID) = IMAGE(SAMP,RESID) - IMAGE(SAMP,DATA)
		ERROR = ERROR + IMAGE(SAMP,RESID)**2
	    ENDDO
	    CALL XVWRIT (UNIT(RESID), IMAGE(1,RESID), STATUS,
     +						 'LINE',LINE,' ')
	ENDDO

	RETURN
	END

	SUBROUTINE FIRSTALPHA
	INCLUDE 'mem.inc'
	REAL	GRAD(3), GHDGE, GEDGE

	GHDGE = 0.0
	GEDGE = 0.0
	IF (RESTART) THEN
	    DO LINE = 1, NL
	        CALL XVREAD(UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +				'LINE',LINE,' ')
	        CALL XVREAD(UNIT(DEF), IMAGE(1,DEF), STATUS,
     +				 'LINE',LINE,' ')
	        CALL XVREAD(UNIT(GRDE),IMAGE(1,GRDE),STATUS,
     +				'LINE',LINE,' ')
	        DO SAMP = 1, NS
		    GRAD(H) = -LOG( IMAGE(SAMP,CURRENT)/IMAGE(SAMP,DEF) )
		    GRAD(E) = 2.0*IMAGE(SAMP,GRDE)
		    GHDGE = GHDGE + GRAD(H)*GRAD(E)
		    GEDGE = GEDGE + GRAD(E)**2
	        ENDDO
	    ENDDO
	    ALPHA = GHDGE/GEDGE
	ELSE
	    DO LINE = 1, NL
	        CALL XVREAD(UNIT(GRDE),IMAGE(1,GRDE),STATUS,
     +				'LINE',LINE,' ')
	        DO SAMP = 1, NS
		    GRAD(E) = 2.0*IMAGE(SAMP,GRDE)
		    GEDGE = GEDGE + GRAD(E)**2
	        ENDDO
	    ENDDO
	    ALPHA = 1.0/SQRT(GEDGE/NPIXELS)
	ENDIF

	RETURN
	END

	SUBROUTINE TAKESTEP
	INCLUDE 'mem.inc'

	IMAGEMIN = 1.0E20
	DO LINE = 1, NL
	    CALL XVREAD(UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +			 'LINE',LINE, ' ')
	    CALL XVREAD(UNIT(STEP), IMAGE(1,STEP), STATUS,
     +			 'LINE',LINE,' ')
	    DO SAMP = 1, NS
		IMAGE(SAMP,CURRENT) = IMAGE(SAMP,CURRENT)
     +				+ STEPLEN * IMAGE(SAMP,STEP)
		IMAGEMIN = MIN (IMAGEMIN, IMAGE(SAMP,CURRENT) )
	    ENDDO
	    CALL XVWRIT (UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +			 'LINE',LINE, ' ')
	ENDDO

	RETURN
	END

	SUBROUTINE MAKENEWRESID
	INCLUDE 'mem.inc'

	ERROR = 0.0
	DO LINE = 1, NL
	    CALL XVREAD(UNIT(RESID), IMAGE(1,RESID), STATUS,
     +				 'LINE',LINE,' ')
	    CALL XVREAD(UNIT(CNVSTP),IMAGE(1,CNVSTP),STATUS,
     +				'LINE',LINE,' ')
	    DO SAMP = 1, NS
		IMAGE(SAMP,RESID) = IMAGE(SAMP,RESID)
     +				+ STEPLEN * IMAGE(SAMP,CNVSTP)
		ERROR = ERROR + IMAGE(SAMP,RESID)**2
	    ENDDO
	    CALL XVWRIT (UNIT(RESID), IMAGE(1,RESID), STATUS,
     +				'LINE',LINE,' ')
	ENDDO
	RMSERROR = SQRT(ERROR/NPIXELS)

	RETURN
	END

	SUBROUTINE TERMOUTPUT
	INCLUDE 'mem.inc'
	CHARACTER*60  STRING

	WRITE (STRING,101) ' Iteration ',ITER, ' of ', MAXITER
101	FORMAT (A,I3,A,I3)
	CALL xvmessage (STRING,' ')
	WRITE (STRING,103) '     RMS Error          : ',RMSERROR
103	FORMAT (A,F12.4)
	CALL xvmessage (STRING,' ')
	WRITE (STRING,105) '     Solution Criterion : ',SOLUCRIT
105	FORMAT (A,F8.4)
	CALL xvmessage (STRING,' ')

C	TYPE *,'     Step Length        : ',STEPLEN
C	TYPE *,'     Alpha              : ', ALPHA

	RETURN
	END

	REAL FUNCTION CALCJAY (LENGTH)
	INCLUDE 'mem.inc'
	REAL	LENGTH
	REAL	ENTROPY, OUTPIXEL

	ENTROPY = 0.0
	DO LINE = 1, NL
	    CALL XVREAD(UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +				 'LINE',LINE, ' ')
	    CALL XVREAD(UNIT(STEP), IMAGE(1,STEP), STATUS,
     +				 'LINE',LINE,' ')
	    CALL XVREAD(UNIT(DEF), IMAGE(1,DEF), STATUS,
     +				 'LINE',LINE,' ')
	    DO SAMP = 1, NS
		OUTPIXEL = IMAGE(SAMP,CURRENT)+LENGTH*IMAGE(SAMP,STEP)
		ENTROPY = ENTROPY - OUTPIXEL
     +			  *( LOG(OUTPIXEL/IMAGE(SAMP,DEF)) - 1.0 )
	    ENDDO
	ENDDO

	CALCJAY = ENTROPY - ALPHA*(E0 + 2*E1*LENGTH + E2*LENGTH**2)

	RETURN
	END

	SUBROUTINE CALCSTEPLEN
	INCLUDE 'mem.inc'
	REAL	LENLOW, LENUP, LENA, LENB
	REAL	JAYLOW, JAYUP, JAYA, JAYB, CALCJAY

	E0 = ERROR
	E1 = 0.0
	E2 = 0.0
	DO LINE = 1, NL
	    CALL XVREAD(UNIT(RESID), IMAGE(1,RESID), STATUS,
     +				 'LINE',LINE,' ')
	    CALL XVREAD(UNIT(CNVSTP),IMAGE(1,CNVSTP),STATUS,
     +				'LINE',LINE,' ')
	    DO SAMP = 1, NS
		E1 = E1 + IMAGE(SAMP,RESID) * IMAGE(SAMP,CNVSTP)
		E2 = E2 + IMAGE(SAMP,CNVSTP)**2
	    ENDDO
	ENDDO

	LENLOW = 0.0
	LENUP = MAXSTEPLEN

	LENA = LENUP - 0.618*(LENUP-LENLOW)
	JAYA = CALCJAY(LENA)
	LENB = LENLOW + 0.618*(LENUP-LENLOW)
	JAYB = CALCJAY(LENB)

	DO WHILE (ABS((LENB-LENA)/LENA) .GT. 0.05)
	    IF (JAYA .GT. JAYB) THEN
		LENUP = LENB
		JAYUP = JAYB
		LENB = LENA
		JAYB = JAYA
		LENA = LENUP - 0.618*(LENUP-LENLOW)
		JAYA = CALCJAY (LENA)
	    ELSE
		LENLOW = LENA
		JAYLOW = JAYA
		LENA = LENB
		JAYA = JAYB
		LENB = LENLOW + 0.618*(LENUP-LENLOW)
		JAYB = CALCJAY (LENB)
	    ENDIF
	ENDDO

	IF (JAYA .GT. JAYB)  THEN
	    STEPLEN = LENA
	ELSE
	    STEPLEN = LENB
	ENDIF

	MAXSTEPLEN = 2.0*STEPLEN

	RETURN
	END

	SUBROUTINE CALCSTEP
	INCLUDE 'mem.inc'
	REAL	TMP, INVGRDGRDJ, DELPIX
	REAL	GRAD(3)

	TMP = 2.0*ALPHA*PSFVOLUME

	DO LINE = 1, NL
	    CALL XVREAD(UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +					'LINE',LINE,' ')
	    CALL XVREAD(UNIT(DEF), IMAGE(1,DEF), STATUS,
     +					 'LINE',LINE,' ')
	    CALL XVREAD(UNIT(GRDE), IMAGE(1,GRDE), STATUS,
     +					 'LINE',LINE,' ')
	    DO SAMP = 1, NS
		GRAD(H) = -LOG( IMAGE(SAMP,CURRENT)/IMAGE(SAMP,DEF) )
		GRAD(E) = 2.0*IMAGE(SAMP,GRDE)
		GRAD(J) = GRAD(H) - ALPHA*GRAD(E)
		INVGRDGRDJ = 1.0/( 1.0/IMAGE(SAMP,CURRENT) + TMP)
		DELPIX = INVGRDGRDJ * GRAD(J)
		DELPIX = MAX( DELPIX,
     +			  (0.1*IMAGEMIN-IMAGE(SAMP,CURRENT))/MAXSTEPLEN )
		IMAGE(SAMP,STEP) = DELPIX
	    ENDDO
	    CALL XVWRIT (UNIT(STEP), IMAGE(1,STEP), STATUS,
     +					 'LINE',LINE,' ')
	ENDDO

	RETURN
	END

	SUBROUTINE UPDATEALPHA
	INCLUDE 'mem.inc'
	INTEGER	I1, I2
	REAL	TMP, INVGRDGRDJ
	REAL	GRAD(3)
	REAL	A, B, C, DELTAALPHA, ALPHAUPBND, ALPHALOWBND

	DO I1 = 1, 3
	    DO I2 = 1, 3
		GRADDOTGRAD(I1,I2) = 0.0
	    ENDDO
	ENDDO

	TMP = 2.0*ALPHA*PSFVOLUME

	DO LINE = 1, NL
	    CALL XVREAD(UNIT(CURRENT), IMAGE(1,CURRENT), STATUS,
     +					 'LINE',LINE, ' ')
	    CALL XVREAD(UNIT(DEF), IMAGE(1,DEF), STATUS,
     +					 'LINE',LINE,' ')
	    CALL XVREAD(UNIT(GRDE), IMAGE(1,GRDE), STATUS,
     +					'LINE',LINE,' ')
	    DO SAMP = 1, NS
		GRAD(H) = -LOG( IMAGE(SAMP,CURRENT)/IMAGE(SAMP,DEF) )
		GRAD(E) = 2.0*IMAGE(SAMP,GRDE)
		GRAD(J) = GRAD(H) - ALPHA*GRAD(E)
		INVGRDGRDJ = 1.0/( 1.0/IMAGE(SAMP,CURRENT) + TMP)
		DO I1 = 1, 3
		    DO I2 = I1, 3
			GRADDOTGRAD(I1,I2) = GRADDOTGRAD(I1,I2) +
     +				GRAD(I1) * INVGRDGRDJ * GRAD(I2)
		    ENDDO
		ENDDO
	    ENDDO
	ENDDO

	DO I1 = 1, 3
	    DO I2 = I1, 3
		GRADDOTGRAD(I2,I1) = GRADDOTGRAD(I1,I2)
	    ENDDO
	ENDDO

	COMPOFGRADJ = GRADDOTGRAD(H,H) + ALPHA**2 *GRADDOTGRAD(E,E)
	IF (COMPOFGRADJ .GT. 0.0) THEN
	    SOLUCRIT = GRADDOTGRAD(J,J) / COMPOFGRADJ
	ELSE
	    SOLUCRIT = 0.0
	ENDIF

	IF (SOLUCRIT .LT. MAXCRIT) THEN

	    DELTAALPHA = (ERROR - TARGETERROR)/ GRADDOTGRAD(E,E)

C	    A = (1-MAXCRIT)* GRADDOTGRAD(E,E)
C	    B = -GRADDOTGRAD(J,E) - MAXCRIT*ALPHA*GRADDOTGRAD(E,E)
C	    C = GRADDOTGRAD(J,J) - MAXCRIT *COMPOFGRADJ

	    A = GRADDOTGRAD(E,E)		! Tim Cornwell's method
	    B = -GRADDOTGRAD(J,E)
	    C = GRADDOTGRAD(J,J) - MAXCRIT *COMPOFGRADJ

	    ALPHAUPBND = ( -B + SQRT(B**2 - A*C) )/ A
	    ALPHALOWBND = ( -B - SQRT(B**2 - A*C) )/ A

	    DELTAALPHA = MIN (MAX( DELTAALPHA, ALPHALOWBND), ALPHAUPBND)
	    ALPHA = ALPHA + DELTAALPHA
	    ALPHA = MAX( ALPHA, 0.0)

	ENDIF

	RETURN
	END

	SUBROUTINE READPSF
	INCLUDE 'mem.inc'

	REAL	VOLUME

	VOLUME = 0.0
	DO LINE = 1, NLPSF
	    CALL XVREAD(UNIT(PSF), IMAGE(1,PSF), STATUS,
     +						 'LINE',LINE,' ')
	    DO SAMP = 1, NSPSF
		PSFIMAGE(SAMP,LINE) = IMAGE(SAMP,PSF)
		VOLUME = VOLUME + PSFIMAGE(SAMP,LINE)
	    ENDDO
	ENDDO

	if (volume.eq.0.0) call mabend(' ** empty PSF file **')

	DO LINE = 1, NLPSF
	    DO SAMP = 1, NSPSF
		PSFIMAGE(SAMP,LINE)= PSFIMAGE(SAMP,LINE)/VOLUME
	    ENDDO
	ENDDO

	RETURN
	END

	SUBROUTINE MAKEXFER
	INCLUDE 'mem.inc'

	REAL	VOLUME
	COMPLEX CBUFFER(2048), TWOPII

	TWOPII = 2*3.1415926*(0,1)

	VOLUME = 0.0
	DO LINE = 1, NLPSF
	    CALL XVREAD(UNIT(PSF), IMAGE(1,PSF), STATUS,
     +					 'LINE',LINE,' ')
	    DO SAMP = 1, NSPSF
		VOLUME = VOLUME + IMAGE(SAMP,PSF)
	    ENDDO
	ENDDO
	VOLUME = VOLUME*NLFFT*NSFFT

	DO LINE = 1, NLPSF
	    CALL XVREAD(UNIT(PSF), IMAGE(1,PSF), STATUS,
     +					 'LINE',LINE,' ')
	    DO SAMP = 1, NSPSF
		IMAGE(SAMP,XFER)= IMAGE(SAMP,PSF)/VOLUME
	    ENDDO
	    DO SAMP = NSPSF+1, NSFFT
		IMAGE(SAMP,XFER) = 0.0
	    ENDDO
	    CALL XVWRIT (UNIT(XFER), IMAGE(1,XFER), STATUS,
     +					 'LINE',LINE,' ')
	ENDDO
	DO SAMP = 1, NSFFT
	    IMAGE(SAMP,XFER) = 0.0
	ENDDO
	DO LINE = NLPSF+1, NLFFT
	    CALL XVWRIT (UNIT(XFER), IMAGE(1,XFER), STATUS,
     +					 'LINE',LINE,' ')
	ENDDO

	CALL FFTVICARR (UNIT(XFER), NLFFT,NSFFT, +1, XFERCOLBUF)

	DO LINE = 1, NLFFT
	    CALL XVREAD(UNIT(XFER), CBUFFER, STATUS,
     +					 'LINE',LINE,' ')
	    DO SAMP = 1, NSFFT/2
		CBUFFER(SAMP) = CBUFFER(SAMP)
     +		 * CEXP(-TWOPII*( FLOAT(LINE-1)*INT(NLPSF/2.)/NLFFT
     +			       +  FLOAT(SAMP-1)*INT(NSPSF/2.)/NSFFT ) )
	    ENDDO
	    CALL XVWRIT (UNIT(XFER), CBUFFER, STATUS, 'LINE',LINE)
	    XFERCOLBUF(LINE) = XFERCOLBUF(LINE)
     +			 * CEXP(-TWOPII*( FLOAT(LINE-1)*INT(NLPSF/2.)/NLFFT
     +				       + FLOAT(NSFFT/2)*INT(NSPSF/2.)/NSFFT ) )

	ENDDO

	RETURN
	END

	SUBROUTINE CONVIMAGE (INIM, OUTIM, CONJGFLAG)
	INCLUDE 'mem.inc'

	INTEGER	INIM, OUTIM
	LOGICAL CONJGFLAG

	IF (SMALLPSF) THEN
	    CALL CONVDIRECT (INIM, OUTIM, CONJGFLAG)
	ELSE
	    CALL CONVFFT (INIM, OUTIM, CONJGFLAG)
	ENDIF

	RETURN
	END

	SUBROUTINE CONVDIRECT (INIM, OUTIM, CONJGFLAG)
C		CONVOLVES THE INPUT WITH THE PSF AND STORES THE
C		    RESULT IN OUTPUT.  PERFORMS CONVOLUTION DIRECTLY
C		    USING A CIRCULAR LINE BUFFER FOR THE IMAGE.
C		  CONJGFLAG IS TRUE IF THE PSF SHOULD BE FLIPPED
C
	INCLUDE 'mem.inc'

	INTEGER	INIM, OUTIM
	LOGICAL CONJGFLAG
	INTEGER	LSTART, LEND, BUFLINE, SSTART, L, S, CONVLINE, SOFF, LOFF
	REAL	SUM

	SSTART = NSPSF/2 + 1
	IF (.NOT. CONJGFLAG .AND. (MOD( NSPSF, 2) .EQ. 0)) SSTART =
     +						 SSTART - 1
	LSTART = 1 - NLPSF/2
	IF (CONJGFLAG .AND. (MOD( NLPSF, 2) .EQ. 0)) LSTART =
     +						 LSTART + 1
	LEND = NL + LSTART - 1

	DO LINE = 2 - NLPSF , NL
	    BUFLINE = MOD( LINE + NLPSF - 2, NLPSF) + 1
	    IF (LINE .GE. LSTART .AND. LINE .LE. LEND) THEN
		CALL XVREAD(UNIT(INIM), CONVBUF(SSTART,BUFLINE),
     +			  STATUS, 'LINE',LINE-LSTART+1,' ')
	    ELSE
	        DO SAMP = 1, NS+NSPSF+2
		    CONVBUF(SAMP,BUFLINE) = 0.0
	        ENDDO
	    ENDIF

	    IF (LINE .GE. 1) THEN
		DO SAMP = 1, NS
		    SUM = 0.0
		    IF (CONJGFLAG) THEN
			SOFF = SAMP - 1
			LOFF = LINE - 2
			DO L = 1, NLPSF
			    CONVLINE = MOD(LOFF+L, NLPSF) + 1
			    DO S = 1, NSPSF
				SUM = SUM + PSFIMAGE(S,L)
     +				       *CONVBUF(SOFF+S,CONVLINE)
			    ENDDO
			ENDDO
		    ELSE
			SOFF = NSPSF + SAMP
			LOFF = NLPSF + LINE - 1
			DO L = 1, NLPSF
			    CONVLINE = MOD( LOFF-L, NLPSF) + 1
			    DO S = 1, NSPSF
				SUM = SUM + PSFIMAGE(S,L)
     +				       *CONVBUF(SOFF-S,CONVLINE)
			    ENDDO
			ENDDO
		    ENDIF
		    IMAGE(SAMP,OUTIM) = SUM
		ENDDO
		CALL XVWRIT (UNIT(OUTIM), IMAGE(1,OUTIM), STATUS,
     +					'LINE',LINE,' ')
	    ENDIF
	ENDDO

	RETURN
	END

	SUBROUTINE CONVFFT (INIM, OUTIM, CONJGFLAG)
C		CONVOLVES THE INPUT WITH THE PSF AND STORES THE
C		    RESULT IN OUTPUT.  PERFORMS CONVOLUTION USING FFT'S.
C		  CONJGFLAG IS TRUE IF THE PSF SHOULD BE FLIPPED
C
	INCLUDE 'mem.inc'

	INTEGER	INIM, OUTIM
	LOGICAL CONJGFLAG
	COMPLEX	FCOLBUF(4096), FBUFFER(2048), XFERBUFFER(2048)

C		COPY THE INPUT IMAGE INTO THE FFT SCRATCH FILE
C		    AND PAD WITH ZEROS
	DO LINE = 1, NL
	    CALL XVREAD(UNIT(INIM), IMAGE(1,INIM), STATUS,
     +						 'LINE',LINE,' ')
	    DO SAMP = 1, NS
		IMAGE(SAMP,TMPFFT) = IMAGE(SAMP,INIM)
	    ENDDO
	    DO SAMP = NS+1, NSFFT
		IMAGE(SAMP,TMPFFT) = 0.0
	    ENDDO
	    CALL XVWRIT(UNIT(TMPFFT),IMAGE(1,TMPFFT),STATUS,
     +						'LINE',LINE,' ')
	ENDDO
	DO LINE = NL+1, NLFFT
	    DO SAMP = 1, NSFFT
		IMAGE(SAMP,TMPFFT) = 0.0
	    ENDDO
	    CALL XVWRIT(UNIT(TMPFFT),IMAGE(1,TMPFFT),STATUS,
     +						'LINE',LINE,' ')
	ENDDO

C		FFT THE INPUT IMAGE
	CALL FFTVICARR (UNIT(TMPFFT), NLFFT,NSFFT, +1, FCOLBUF)

C		COMPLEX MULTIPLY THE TRANSFORM OF THE INPUT IMAGE
C		    BY THE TRANSFER IMAGE
	DO LINE = 1, NLFFT
	    CALL XVREAD(UNIT(TMPFFT), FBUFFER, STATUS,
     +						 'LINE',LINE,' ')
	    CALL XVREAD(UNIT(XFER), XFERBUFFER, STATUS,
     +						 'LINE',LINE,' ')
	    DO SAMP = 1, NSFFT/2
		IF (CONJGFLAG)  XFERBUFFER(SAMP) =
     +					 CONJG(XFERBUFFER(SAMP))
		FBUFFER(SAMP) = FBUFFER(SAMP) * XFERBUFFER(SAMP)
	    ENDDO
	    CALL XVWRIT(UNIT(TMPFFT), FBUFFER, STATUS,
     +						 'LINE',LINE,' ')
	    IF (CONJGFLAG)  XFERCOLBUF(LINE) =
     +					 CONJG(XFERCOLBUF(LINE))
	    FCOLBUF(LINE) = FCOLBUF(LINE)* XFERCOLBUF(LINE)
	ENDDO

C		FFT BACK TO GET THE CONVOLVED IMAGE
	CALL FFTVICARR (UNIT(TMPFFT), NLFFT,NSFFT, -1, FCOLBUF)

C		COPY INTO THE OUTPUT FILE
	DO LINE = 1, NL
	    CALL XVREAD(UNIT(TMPFFT),IMAGE(1,TMPFFT),STATUS,
     +						'LINE',LINE,' ')
	    CALL XVWRIT(UNIT(OUTIM), IMAGE(1,TMPFFT), STATUS,
     +						 'LINE',LINE,' ')
	ENDDO

	RETURN
	END

	SUBROUTINE FFTVICARR (UNIT, NLFFT, NSFFT, FFTSIGN, COLBUF)
C
C
C	FFTVICARR IS A TWO DIMENSIONAL FAST FOURIER TRANSFORM ROUTINE.
C	    IT DOES AN IN PLACE REAL TO COMPLEX CONJUGATE OR COMPLEX
C	    CONJUGATE TO REAL TRANSFORM ON AN EXISTING VICAR IMAGE.
C	    THE IMAGE MUST BE ALREADY OPENED FOR UPDATE WITH XVOPEN,
C	    WITH REAL FORMATS, AND HAVE REAL SIZE NLFFT BY NSFFT
C	    WHICH MUST BE POWERS OF TWO.
C	    THE SIGN (+1 OR -1) OF THE TRANSFORM IS PASSED IN FFTSIGN.
C	    IF FFTSIGN = +1 THEN THE TRANSFORM IS REAL TO COMPLEX CONJUGATE
C	    AND IF FFTSIGN = -1 THEN THEN TRANSFORM IS THE OTHER WAY.
C	    COLBUF IS A COMPLEX ARRAY OF LENGTH EQUAL TO THE NUMBER OF ROWS.
C	      IT CONTAINS THE 'EXTRA' COLUMN FOR THE COMPLEX CONJUGATE FORMAT.
C	    THE MAXIMUM SIZE IN EITHER DIRECTION IS 32768.
C	THE TRANSFORM DOES NOT TRANSPOSE THE IMAGE AND THE ZERO-FREQUENCY
C	    PIXEL IS AT THE FIRST LINE AND SAMPLE.
C
C
	IMPLICIT NONE
	INTEGER	UNIT, NLFFT, NSFFT, FFTSIGN
	INTEGER	MAXN, LINE, STATUS, BUFPTR
	COMPLEX COLBUF(1)
	INTEGER*2 BITREV(8192)
	COMPLEX BUFFER(512*256), PHASE(8192)

	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	MAXN = MAX(NLFFT,NSFFT)
	CALL MAKEBITREV (BITREV, MAXN)
	CALL MAKEPHASE (PHASE, FFTSIGN, MAXN)

	IF (NLFFT*NSFFT .GT. 512*512) THEN

	IF (FFTSIGN .EQ. +1) THEN
	    DO LINE = 1, NLFFT
		CALL XVREAD(UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
		CALL FFTC1D (BUFFER, NSFFT/2)
		CALL FIXREAL (BUFFER, COLBUF(LINE), NSFFT/2, +1)
		CALL XVWRIT(UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
	    ENDDO
	    CALL FFTC1D (COLBUF, NLFFT)
	    CALL FFTC1VD (UNIT, NSFFT/2, NLFFT)
	ELSE
	    CALL FFTC1VD (UNIT, NSFFT/2, NLFFT)
	    CALL FFTC1D (COLBUF, NLFFT)
	    DO LINE = 1, NLFFT
		CALL XVREAD(UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
		CALL FIXREAL (BUFFER, COLBUF(LINE), NSFFT/2, -1)
		CALL FFTC1D (BUFFER, NSFFT/2)
		CALL XVWRIT(UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
	    ENDDO
	ENDIF

	ELSE

	IF (FFTSIGN .EQ. +1) THEN
	    DO LINE = 1, NLFFT
		BUFPTR = (NSFFT/2)*(LINE-1)+1
		CALL XVREAD(UNIT, BUFFER(BUFPTR), STATUS,
     +						 'LINE',LINE,' ')
		CALL FFTC1D (BUFFER(BUFPTR), NSFFT/2)
		CALL FIXREAL (BUFFER(BUFPTR), COLBUF(LINE), NSFFT/2,+1)
	    ENDDO
	    CALL FFTCV (BUFFER, NSFFT/2, NLFFT)
	    CALL FFTC1D (COLBUF, NLFFT)
	    DO LINE = 1, NLFFT
		BUFPTR = (NSFFT/2)*(LINE-1)+1
		CALL XVWRIT(UNIT, BUFFER(BUFPTR), STATUS,
     +						 'LINE',LINE,' ')
	    ENDDO
	ELSE
	    DO LINE = 1, NLFFT
		BUFPTR = (NSFFT/2)*(LINE-1)+1
		CALL XVREAD(UNIT, BUFFER(BUFPTR), STATUS,
     +						 'LINE',LINE,' ')
	    ENDDO
	    CALL FFTC1D (COLBUF, NLFFT)
	    CALL FFTCV (BUFFER, NSFFT/2, NLFFT)
	    DO LINE = 1, NLFFT
		BUFPTR = (NSFFT/2)*(LINE-1)+1
		CALL FIXREAL (BUFFER(BUFPTR), COLBUF(LINE), NSFFT/2, -1)
		CALL FFTC1D (BUFFER(BUFPTR), NSFFT/2)
		CALL XVWRIT(UNIT, BUFFER(BUFPTR), STATUS,
     +						 'LINE',LINE,' ')
	    ENDDO
	ENDIF

	ENDIF

	RETURN
	END

	SUBROUTINE MAKEBITREV(BITREV,NMAX)
	IMPLICIT NONE
	INTEGER	I,IREV,J,K,L,M,LMAX,NMAX
	INTEGER*2 BITREV(1)
	INTEGER LOG2

	LMAX=LOG2(NMAX)
	I=0
	DO L=0,LMAX
	    IREV=0
	    DO J=0,2**L-1
		I=I+1
		BITREV(I)=IREV
		DO K=1,L
		    M=2**(L-K)
		    IF (IREV.LT.M) GO TO 70
		    IREV=IREV-M
		END DO
70		IREV=IREV+M
	    END DO
	END DO

	RETURN
	END

	SUBROUTINE MAKEPHASE (PHASE, SIGN, NMAX)
	IMPLICIT NONE
	INTEGER	I,J,L,LMAX,NMAX,SIGN, LOG2
	COMPLEX	PHASE(1)

	LMAX=LOG2(NMAX)
	J=0
	DO L=0,LMAX
	    DO I=0,2**L-1
		J=J+1
		PHASE(J) = CEXP(SIGN*2*3.1415926535*(0,1)*FLOAT(I)/2**L)
	    END DO
	END DO

	RETURN
	END

	SUBROUTINE FFTC1D (DATA, N)
	IMPLICIT NONE
	INTEGER	I,J,K,N,LN,M0,M1,JMAX,OFF,IDXPH,POWER, LOG2
	INTEGER*2 BITREV(1)
	COMPLEX	DATA(1),TMP,PHASE(1)
	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	LN = LOG2(N)
	DO I = 0,N-1
	    J = BITREV(I+N)
	    IF (J .GT. I) THEN
		TMP = DATA(I+1)
		DATA(I+1) = DATA(J+1)
		DATA(J+1) = TMP
	    END IF
	END DO

	M0 = 1
	M1 = 2
	JMAX = N/2
	DO J = 1,JMAX
	    TMP = DATA(M1)
	    DATA(M1) = DATA(M0) - TMP
	    DATA(M0) = DATA(M0) + TMP
	    M0 = M0 + 2
	    M1 = M1 + 2
	END DO

	DO I = 1,LN-1
	    POWER = 2**I
	    OFF = 2*POWER
	    M0 = 0
	    M1 = POWER
	    JMAX = 2**(LN-I-1)
	    DO J = 1,JMAX
		IDXPH = OFF
		DO K = 0,POWER-1
		    M0 = M0 + 1
		    M1 = M1 + 1
		    TMP = PHASE(IDXPH)*DATA(M1)
		    IDXPH = IDXPH + 1
		    DATA(M1) = DATA(M0) - TMP
		    DATA(M0) = DATA(M0) + TMP
		END DO
		M0 = M0 + POWER
		M1 = M1 + POWER
	    END DO
	END DO

	RETURN
	END

	SUBROUTINE FIXREAL(DATA,COLBUF,N,DIR)
	IMPLICIT NONE
	INTEGER N,DIR,I,ICONJ,IDXPH
	REAL PHR(2),TMPR
	COMPLEX DATA(1),COLBUF, PHASE(1), TMP0,TMP1, PH
	EQUIVALENCE (PHR(1),PH)
	COMMON  /PHASE/  PHASE

	IDXPH = 2*N+1
	ICONJ = N

	IF (DIR .EQ. +1) THEN
	    COLBUF = REAL(DATA(1))-AIMAG(DATA(1))
	    DATA(1) = REAL(DATA(1))+AIMAG(DATA(1))
	    DO I = 2,N/2+1
		PH = PHASE(IDXPH)
		IDXPH = IDXPH + 1
		TMPR = PHR(1)		! MULT BY i
		PHR(1) = -PHR(2)
		PHR(2) = TMPR
		TMP0 = DATA(I)+CONJG(DATA(ICONJ))
		TMP1 = PH*( DATA(I)-CONJG(DATA(ICONJ)) )
		DATA(I) = (TMP0-TMP1)/2
		DATA(ICONJ) = CONJG(TMP0+TMP1)/2
		ICONJ = ICONJ-1
	    ENDDO
	ELSE
	    DATA(1) = ( REAL(DATA(1)) + REAL(COLBUF) )
     +			+ (0,1)*( REAL(DATA(1)) - REAL(COLBUF) )
	    DO I = 2,N/2+1
		PH = PHASE(IDXPH)
		IDXPH = IDXPH + 1
		TMPR = PHR(1)		! MULT BY -i
		PHR(1) = PHR(2)
		PHR(2) = -TMPR
		TMP0 = DATA(I)+CONJG(DATA(ICONJ))
		TMP1 = PH*( DATA(I)-CONJG(DATA(ICONJ)) )
		DATA(I) = TMP0-TMP1
		DATA(ICONJ) = CONJG(TMP0+TMP1)
		ICONJ = ICONJ-1
	    ENDDO
	ENDIF

	RETURN
	END

	SUBROUTINE FFTC1VD (UNIT, NS, NL)
	IMPLICIT NONE
	INTEGER	I,J,K,C,NS,NL,LNL,ROW0,ROW1,JMAX,OFF
	INTEGER*2 BITREV(1)
	COMPLEX	PHASE(1)
	INTEGER	POWER,STAT, LOG2, UNIT
	COMPLEX	DATA0(4096),DATA1(4096),TMP0,TMP1,PH
	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	LNL=LOG2(NL)
	DO I=0,NL-1
	    J=BITREV(I+NL)
	    IF (J.GT.I) THEN
		CALL XVREAD(UNIT, DATA0, STAT, 'LINE',I+1,' ')
		CALL XVREAD(UNIT, DATA1, STAT, 'LINE',J+1,' ')
		CALL XVWRIT(UNIT, DATA0, STAT, 'LINE',J+1,' ')
		CALL XVWRIT(UNIT, DATA1, STAT, 'LINE',I+1,' ')
	    END IF
	END DO

	DO I=0,LNL-1
	    JMAX=2**(LNL-I-1)
	    POWER=2**I
	    OFF=2*POWER
	    DO J=0,JMAX-1
		ROW0=OFF*J
		ROW1=ROW0+POWER
		DO K=0,POWER-1
		    ROW0=ROW0+1
		    ROW1=ROW1+1
		    PH=PHASE(K+OFF)
		    CALL XVREAD(UNIT, DATA0, STAT, 'LINE',ROW0,' ')
		    CALL XVREAD(UNIT, DATA1, STAT, 'LINE',ROW1,' ')
		    DO C=1,NS
			TMP0=DATA0(C)
			TMP1=PH*DATA1(C)
			DATA0(C)=TMP0+TMP1
			DATA1(C)=TMP0-TMP1
		    END DO
		    CALL XVWRIT(UNIT, DATA0, STAT, 'LINE',ROW0,' ')
		    CALL XVWRIT(UNIT, DATA1, STAT, 'LINE',ROW1,' ')
		END DO
	    END DO
	END DO

	RETURN
	END

	SUBROUTINE FFTCV(DATA,NS,NL)
	IMPLICIT NONE
	INTEGER	I,J,K,C,NS,NL,LNL,M0,M1,JMAX,OFF, LOG2
	INTEGER POWER,IDXPH
	INTEGER*2 BITREV(1)
	COMPLEX	DATA(1),TMP,PHASE(1),PH
	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	LNL = LOG2(NL)
	DO I = 0,NL-1
	    J = BITREV(I+NL)
	    IF (J .GT. I) THEN
		M0 = NS*I
		M 1= NS*J
		DO C = 1,NS
		    M0 = M0 + 1
		    M1 = M1 + 1
		    TMP = DATA(M0)
		    DATA(M0) = DATA(M1)
		    DATA(M1) = TMP
		END DO
	    END IF
	END DO

	DO I = 0,LNL-1
	    JMAX = 2**(LNL-I-1)
	    POWER = 2**I
	    OFF = 2*POWER
	    M0 = 0
	    M1 = POWER*NS
	    DO J = 0,JMAX-1
		IDXPH = OFF
		DO K = 0,POWER-1
		    PH = PHASE(IDXPH)
		    IDXPH = IDXPH + 1
		    DO C = 1,NS
			M0 = M0 + 1
			M1 = M1 + 1
			TMP = PH*DATA(M1)
			DATA(M1) = DATA(M0) - TMP
			DATA(M0) = DATA(M0) + TMP
		    END DO
		END DO
		M0 = M0 + POWER*NS
		M1 = M1 + POWER*NS
	    END DO
	END DO

	RETURN
	END

	INTEGER FUNCTION LOG2(N)
	IMPLICIT NONE
	INTEGER	N
	LOG2 = 2
	DO WHILE (ISHFT(N,-LOG2) .GT. 0)
	    LOG2 = LOG2 + 1
	ENDDO
	LOG2 = LOG2 - 1
	RETURN
	END


SUBROUTINE DetermineTransformationConstants(Nx,Ny,Nz,FineGrid,dsigma,Wavefield)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: FineGrid
INTEGER :: Nx,Ny,Nz,Gidx
REAL(KIND=long) :: d, z
REAL(KIND=long), DIMENSION(Nx*Ny*Nz,5), INTENT(OUT) :: dsigma
REAL(KIND=long), DIMENSION(Nx,Ny) :: E,Ex,Exx,Ey,Eyy,h,hx,hxx,hy,hyy
REAL(KIND=long), DIMENSION(Nz) :: zgrid
TYPE(Wavefield_FS) :: Wavefield
!Local variables
INTEGER :: i,j,k
h = FineGrid%h
E = Wavefield%E
IF (Nx>1) THEN
	hx  = FineGrid%hx
	hxx = FineGrid%hxx
    Ex  = Wavefield%Ex
    Exx = Wavefield%Exx
ENDIF
IF (Ny>1) THEN
	hy  = FineGrid%hy
	hyy = FineGrid%hyy
    Ey  = Wavefield%Ey
    Eyy = Wavefield%Eyy
ENDIF
! GD: SWENSE addition for nonlinear
! FIXME: during transition period we do not satisfy Ex+Ex_I=0 nor Ey+Ey_I=0...
! The incident terms used here are without time ramp...
! Include this possibility in the NormalZ which will be =/ 0 on horiz. boundaries ?
IF (ASSOCIATED(Wavefield%E_I)) THEN ! This means that swense is ON
  E = E + Wavefield%E_I
  IF (Nx>1) THEN
      Ex  = Ex  + Wavefield%Ex_I
      Exx = Exx + Wavefield%Exx_I
  ENDIF
  IF (Ny>1) THEN
      Ey  = Ey  + Wavefield%Ey_I
      Eyy = Eyy + Wavefield%Eyy_I
  ENDIF
ENDIF
zgrid = FineGrid%z
! Assume that z=0 at below bottom ghost layer.
zgrid(1) = zero
Gidx = 0
IF (Ny==1) THEN
  j = 1
  DO i = 1, Nx
	DO k = 1, Nz
		Gidx = Gidx + 1;
		! Determine z-coordinate (NOTE THAT ACTUALLY sigma = z, see below)
		z = zgrid(k)
		d = E(i,j)+h(i,j)
		! sigma
		dsigma(Gidx,1) = z ! (z+h(i,j))/d
	    ! d(sigma)/dx
		dsigma(Gidx,2) = ((one-dsigma(Gidx,1))*hx(i,j)-dsigma(Gidx,1)*Ex(i,j))/d
!		dsigma(Gidx,2) = (one-dsigma(Gidx,1))/d*hx(i,j)-dsigma(Gidx,1)/d*Ex(i,j)
	    ! d^2(sigma)/dx^2
	    dsigma(Gidx,3) = -two*(one-dsigma(Gidx,1))*(hx(i,j)**2)/d**2+&
		  two*(two*dsigma(Gidx,1)-one)*(Ex(i,j)*hx(i,j))/d**2+&
		  (one-dsigma(Gidx,1))*(hxx(i,j))/d+two*dsigma(Gidx,1)*(Ex(i,j)**2)/d**2-dsigma(Gidx,1)*(Exx(i,j))/d
		! d(sigma)/dz
		dsigma(Gidx,5) = one/d
	END DO
  END DO
ELSE IF (Nx==1) THEN
  i = 1
  DO j = 1, Ny
	DO k = 1, Nz
		Gidx = Gidx + 1;
		! Determine z-coordinate (NOTE THAT ACTUALLY sigma = z, see below)
		z = zgrid(k)
		d = E(i,j)+h(i,j)
		! sigma
		dsigma(Gidx,1) = z ! (z+h(i,j))/d
	    ! d^2(sigma)/dy^2
		dsigma(Gidx,3) = -two*(one-dsigma(Gidx,1))*(hy(i,j)**2)/d**2+&
		  two*(two*dsigma(Gidx,1)-one)*(Ey(i,j)*hy(i,j))/d**2+&
		  (one-dsigma(Gidx,1))*(hyy(i,j))/d+two*dsigma(Gidx,1)*(Ey(i,j)**2)/d**2-dsigma(Gidx,1)*(Eyy(i,j))/d
	    ! d(sigma)/dy
		dsigma(Gidx,4) = ((one-dsigma(Gidx,1))*hy(i,j)-dsigma(Gidx,1)*Ey(i,j))/d
		! d(sigma)/dz
		dsigma(Gidx,5) = one/d
	END DO
  END DO
ELSE ! 3D
  DO j = 1, Ny
	DO i = 1, Nx
		DO k = 1, Nz
			Gidx = Gidx + 1;
			! Determine z-coordinate (NOTE THAT ACTUALLY sigma = z, see below)
			z = zgrid(k)
			d = E(i,j)+h(i,j)
			! sigma
			dsigma(Gidx,1) = z ! (z+h(i,j))/d
		    ! d(sigma)/dx
			dsigma(Gidx,2) = ((one-dsigma(Gidx,1))*hx(i,j)-dsigma(Gidx,1)*Ex(i,j))/d
		    ! d^2(sigma)/dx^2+d^2(sigma)/dy^2
			dsigma(Gidx,3) = -two*(one-dsigma(Gidx,1))*(hx(i,j)**2+hy(i,j)**2)/d**2+&
			  two*(two*dsigma(Gidx,1)-one)*(Ex(i,j)*hx(i,j)+Ey(i,j)*hy(i,j))/d**2+&
			  (one-dsigma(Gidx,1))*(hxx(i,j)+hyy(i,j))/d+two*dsigma(Gidx,1)*(Ex(i,j)**2+&
			  Ey(i,j)**2)/d**2-dsigma(Gidx,1)*(Exx(i,j)+Eyy(i,j))/d
		    ! d(sigma)/dy
			dsigma(Gidx,4) = ((one-dsigma(Gidx,1))*hy(i,j)-dsigma(Gidx,1)*Ey(i,j))/d
			! d(sigma)/dz
			dsigma(Gidx,5) = one/d
		END DO
	END DO
  END DO
ENDIF
END SUBROUTINE DetermineTransformationConstants


subroutine ll2qvec(	ndat,rlats,rlons,			&
			qr_x,qr_y,qr_z,qm_x,qm_y,qm_z,ql_x,ql_y	)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!
! !ROUTINE: ll2qvec - set unit vectors qr, qm, and ql
!
! !SYNOPSIS:
!
! !INPUT PARAMETERS:
!
! !OUTPUT PARAMETERS:
!
! !DESCRIPTION:
!
! !EXAMPLES:
!
! !BUGS:
!
! !SEE ALSO:
!
! !SYSTEM ROUTINES:
!
! !FILES USED:
!
! !REVISION HISTORY:
! 	08Dec95 - J. Guo	- initial code replacing ll2xyz() and
!				  qtrig0() etc.
!_______________________________________________________________________

implicit none

integer, intent(in)	:: ndat		! size of the arrays
real,    intent(in)	:: rlats(ndat)	! latitudes
real,    intent(in)	:: rlons(ndat)	! longitudes
real,    intent(out)	:: qr_x(ndat)	! x of qr
real,    intent(out)	:: qr_y(ndat)	! y of qr
real,    intent(out)	:: qr_z(ndat)	! z of qr
real,    intent(out)	:: qm_x(ndat)	! x of d(qr)/dm
real,    intent(out)	:: qm_y(ndat)	! y of d(qr)/dm
real,    intent(out)	:: qm_z(ndat)	! z of d(qr)/dm
real,    intent(out)	:: ql_x(ndat)	! x of d(qr)/dl
real,    intent(out)	:: ql_y(ndat)	! y of d(qr)/dl

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! locals
!========
  real    :: slat,clat,slon,clon
  real	  :: deg
  integer :: i

!-----------------------------------------------------------------------
	deg=4.*atan(1.)/180.
!-----------------------------------------------------------------------
do i=1,ndat
  slat=sin(rlats(i)*deg)
  clat=cos(rlats(i)*deg)
  slon=sin(rlons(i)*deg)
  clon=cos(rlons(i)*deg)

  qr_x(i)= clat*clon
  qr_y(i)= clat*slon
  qr_z(i)= slat
  qm_x(i)=-slat*clon
  qm_y(i)=-slat*slon
  qm_z(i)= clat
  ql_x(i)=-slon
  ql_y(i)= clon
end do
!_______________________________________________________________________
end
!.


MODULE ReferenceElementModuleX_Lagrange

  USE KindModule, ONLY: &
    DP, Half
  USE ProgramHeaderModule, ONLY: &
    nNodesX, &
    nDOFX
  USE UtilitiesModule, ONLY: &
    WriteMatrix
  USE PolynomialBasisModule_Lagrange, ONLY: &
     L_X1,  L_X2,  L_X3, &
    dL_X1, dL_X2, dL_X3, &
    LagrangeP
  USE ReferenceElementModuleX, ONLY: &
    nDOFX_X1, &
    nDOFX_X2, &
    nDOFX_X3, &
    NodeNumberTableX, &
    NodeNumberTableX_X1, &
    NodeNumberTableX_X2, &
    NodeNumberTableX_X3, &
    NodesX1,  NodesX2,  NodesX3, &
    NodesLX1, NodesLX2, NodesLX3

  IMPLICIT NONE
  PRIVATE

  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: LX_X1_Dn
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: LX_X1_Up
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: LX_X2_Dn
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: LX_X2_Up
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: LX_X3_Dn
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: LX_X3_Up
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: dLXdX1_q
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: dLXdX2_q
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: dLXdX3_q
  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: LX_L2G

  PUBLIC :: InitializeReferenceElementX_Lagrange
  PUBLIC :: FinalizeReferenceElementX_Lagrange

CONTAINS

  SUBROUTINE InitializeReferenceElementX_Lagrange

    INTEGER :: iNodeX, iNodeX1, iNodeX2, iNodeX3
    INTEGER :: jNodeX, jNodeX1, jNodeX2, jNodeX3
    INTEGER :: iNodeX_X1, iNodeX2_X1, iNodeX3_X1
    INTEGER :: iNodeX_X2, iNodeX1_X2, iNodeX3_X2
    INTEGER :: iNodeX_X3, iNodeX1_X3, iNodeX2_X3

    ALLOCATE( LX_X1_Dn(nDOFX_X1,nDOFX) )
    ALLOCATE( LX_X1_Up(nDOFX_X1,nDOFX) )

    DO iNodeX = 1, nDOFX

      iNodeX1 = NodeNumberTableX(1,iNodeX)
      iNodeX2 = NodeNumberTableX(2,iNodeX)
      iNodeX3 = NodeNumberTableX(3,iNodeX)

      DO iNodeX_X1 = 1, nDOFX_X1

        iNodeX2_X1 = NodeNumberTableX_X1(1,iNodeX_X1)
        iNodeX3_X1 = NodeNumberTableX_X1(2,iNodeX_X1)

        LX_X1_Dn(iNodeX_X1,iNodeX) &
          = L_X1(iNodeX1) % P( - Half ) &
            * L_X2(iNodeX2) % P( NodesX2(iNodeX2_X1) ) &
            * L_X3(iNodeX3) % P( NodesX3(iNodeX3_X1) )

        LX_X1_Up(iNodeX_X1,iNodeX) &
          = L_X1(iNodeX1) % P( + Half ) &
            * L_X2(iNodeX2) % P( NodesX2(iNodeX2_X1) ) &
            * L_X3(iNodeX3) % P( NodesX3(iNodeX3_X1) )

      END DO

    END DO

    ALLOCATE( LX_X2_Dn(nDOFX_X2,nDOFX) )
    ALLOCATE( LX_X2_Up(nDOFX_X2,nDOFX) )

    DO iNodeX = 1, nDOFX

      iNodeX1 = NodeNumberTableX(1,iNodeX)
      iNodeX2 = NodeNumberTableX(2,iNodeX)
      iNodeX3 = NodeNumberTableX(3,iNodeX)

      DO iNodeX_X2 = 1, nDOFX_X2

        iNodeX1_X2 = NodeNumberTableX_X2(1,iNodeX_X2)
        iNodeX3_X2 = NodeNumberTableX_X2(2,iNodeX_X2)

        LX_X2_Dn(iNodeX_X2,iNodeX) &
          = L_X1(iNodeX1) % P( NodesX1(iNodeX1_X2) ) &
            * L_X2(iNodeX2) % P( - Half ) &
            * L_X3(iNodeX3) % P( NodesX3(iNodeX3_X2) )

        LX_X2_Up(iNodeX_X2,iNodeX) &
          = L_X1(iNodeX1) % P( NodesX1(iNodeX1_X2) ) &
            * L_X2(iNodeX2) % P( + Half ) &
            * L_X3(iNodeX3) % P( NodesX3(iNodeX3_X2) )

      END DO

    END DO

    ALLOCATE( LX_X3_Dn(nDOFX_X3,nDOFX) )
    ALLOCATE( LX_X3_Up(nDOFX_X3,nDOFX) )

    DO iNodeX = 1, nDOFX

      iNodeX1 = NodeNumberTableX(1,iNodeX)
      iNodeX2 = NodeNumberTableX(2,iNodeX)
      iNodeX3 = NodeNumberTableX(3,iNodeX)

      DO iNodeX_X3 = 1, nDOFX_X3

        iNodeX1_X3 = NodeNumberTableX_X3(1,iNodeX_X3)
        iNodeX2_X3 = NodeNumberTableX_X3(2,iNodeX_X3)

        LX_X3_Dn(iNodeX_X3,iNodeX) &
          = L_X1(iNodeX1) % P( NodesX1(iNodeX1_X3) ) &
            * L_X2(iNodeX2) % P( NodesX2(iNodeX2_X3) ) &
            * L_X3(iNodeX3) % P( - Half )

        LX_X3_Up(iNodeX_X3,iNodeX) &
          = L_X1(iNodeX1) % P( NodesX1(iNodeX1_X3) ) &
            * L_X2(iNodeX2) % P( NodesX2(iNodeX2_X3) ) &
            * L_X3(iNodeX3) % P( + Half )

      END DO

    END DO

    ALLOCATE( dLXdX1_q(nDOFX,nDOFX) )
    ALLOCATE( dLXdX2_q(nDOFX,nDOFX) )
    ALLOCATE( dLXdX3_q(nDOFX,nDOFX) )

    DO jNodeX = 1, nDOFX

      jNodeX1 = NodeNumberTableX(1,jNodeX)
      jNodeX2 = NodeNumberTableX(2,jNodeX)
      jNodeX3 = NodeNumberTableX(3,jNodeX)

      DO iNodeX = 1, nDOFX

        iNodeX1 = NodeNumberTableX(1,iNodeX)
        iNodeX2 = NodeNumberTableX(2,iNodeX)
        iNodeX3 = NodeNumberTableX(3,iNodeX)

        dLXdX1_q(iNodeX,jNodeX) &
          =  dL_X1(jNodeX1) % P( NodesX1(iNodeX1) ) &
            * L_X2(jNodeX2) % P( NodesX2(iNodeX2) ) &
            * L_X3(jNodeX3) % P( NodesX3(iNodeX3) )

        dLXdX2_q(iNodeX,jNodeX) &
          =    L_X1(jNodeX1) % P( NodesX1(iNodeX1) ) &
            * dL_X2(jNodeX2) % P( NodesX2(iNodeX2) ) &
            *  L_X3(jNodeX3) % P( NodesX3(iNodeX3) )

        dLXdX3_q(iNodeX,jNodeX) &
          =    L_X1(jNodeX1) % P( NodesX1(iNodeX1) ) &
            *  L_X2(jNodeX2) % P( NodesX2(iNodeX2) ) &
            * dL_X3(jNodeX3) % P( NodesX3(iNodeX3) )

      END DO

    END DO

    ALLOCATE( LX_L2G(nDOFX,nDOFX) )

    DO jNodeX = 1, nDOFX

      jNodeX1 = NodeNumberTableX(1,jNodeX)
      jNodeX2 = NodeNumberTableX(2,jNodeX)
      jNodeX3 = NodeNumberTableX(3,jNodeX)

      DO iNodeX = 1, nDOFX

        iNodeX1 = NodeNumberTableX(1,iNodeX)
        iNodeX2 = NodeNumberTableX(2,iNodeX)
        iNodeX3 = NodeNumberTableX(3,iNodeX)

        LX_L2G(iNodeX,jNodeX) &
          = LagrangeP  ( NodesX1(iNodeX1), jNodeX1, NodesLX1, nNodesX(1) ) &
            * LagrangeP( NodesX2(iNodeX2), jNodeX2, NodesLX2, nNodesX(2) ) &
            * LagrangeP( NodesX3(iNodeX3), jNodeX3, NodesLX3, nNodesX(3) )

      END DO

    END DO

    CALL WriteMatrix( nDOFX_X1, nDOFX, LX_X1_Dn, 'LX_X1_Dn.dat' )
    CALL WriteMatrix( nDOFX_X1, nDOFX, LX_X1_Up, 'LX_X1_Up.dat' )
    CALL WriteMatrix( nDOFX_X2, nDOFX, LX_X2_Dn, 'LX_X2_Dn.dat' )
    CALL WriteMatrix( nDOFX_X2, nDOFX, LX_X2_Up, 'LX_X2_Up.dat' )
    CALL WriteMatrix( nDOFX_X3, nDOFX, LX_X3_Dn, 'LX_X3_Dn.dat' )
    CALL WriteMatrix( nDOFX_X3, nDOFX, LX_X3_Up, 'LX_X3_Up.dat' )

    CALL WriteMatrix( nDOFX, nDOFX, dLXdX1_q, 'dLXdX1_q.dat' )
    CALL WriteMatrix( nDOFX, nDOFX, dLXdX2_q, 'dLXdX2_q.dat' )
    CALL WriteMatrix( nDOFX, nDOFX, dLXdX3_q, 'dLXdX3_q.dat' )

    CALL WriteMatrix( nDOFX, nDOFX, LX_L2G, 'LX_L2G.dat' )

  END SUBROUTINE InitializeReferenceElementX_Lagrange

  SUBROUTINE FinalizeReferenceElementX_Lagrange

    DEALLOCATE( LX_X1_Dn )
    DEALLOCATE( LX_X1_Up )
    DEALLOCATE( LX_X2_Dn )
    DEALLOCATE( LX_X2_Up )
    DEALLOCATE( LX_X3_Dn )
    DEALLOCATE( LX_X3_Up )
    DEALLOCATE( dLXdX1_q )
    DEALLOCATE( dLXdX2_q )
    DEALLOCATE( dLXdX3_q )
    DEALLOCATE( LX_L2G )

  END SUBROUTINE FinalizeReferenceElementX_Lagrange

END MODULE ReferenceElementModuleX_Lagrange


! ------------------------------------------------------ !
!  F. Califano, Marzo 2006, M. Faganello, Marzo 2007     !
! Solver equazione di Poisson nel piano x,y.             !
! (1 - de^2 Nabla^2) E = Ohm(right hand side)            !
! Componenti Ex, Ey                                      !
! ------------------------------------------------------ !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!   3D PARALLEL VERSION: FAGANELLO 2010
!**************************************************

subroutine poisson( RHS )

use box_mod
use deriv_mod
use parameter_mod
use dom_distr_mod
use poisson_open
use fields_UJ_mod
use fields_EB_mod
use parallel_mod

IMPLICIT NONE

integer :: ix, iy, iz, ily, ilz

REAL(dp), DIMENSION ( nxl, ny, nz ) :: RHS

REAL(dp),ALLOCATABLE ::  sy(:), sz(:)
REAL(dp),ALLOCATABLE ::  syy1(:,:), syy2(:,:)
REAL(dp),ALLOCATABLE ::  g1(:)
REAL(dp),ALLOCATABLE ::  Rt(:,:,:)
!real*8 :: kkyy, kkzz

allocate(g1(nx))
allocate(sy(ny),sz(nz))
allocate(syy1(ny,nz))
allocate(syy2(ny,nz))
allocate(Rt(nx, nyt, nz))

!test
!kkyy=2.*pgreco/yl
!kkzz=2.*pgreco/zl
!do iz = 1, nz
! do iy = 1, ny
!  do ix = 1, nxl
!   Ex(ix,iy,iz)=tanh(5*(x(ix+ixlg-1)-xl/2.))*cos(kkyy*y(iy))*sin(kkzz*z(iz))
!  enddo
! enddo
!enddo

!call outx

!do iz = 1, nz
! do iy = 1, ny
!  do ix = 1, nxl
!   RHS(ix,iy,iz)=tanh(5.*(x(ix+ixlg-1)-xl/2.))*cos(kkyy*y(iy))*sin(kkzz*z(iz)) - de2 *&
!(-2.*25.*tanh(5.*(x(ix+ixlg-1)-xl/2.))/(cosh(5.*(x(ix+ixlg-1)-xl/2.)))**2 *cos(kkyy*y(iy))*sin(kkzz*z(iz))&
!- kkyy**2 * tanh(5.*(x(ix+ixlg-1)-xl/2.))*cos(kkyy*y(iy))*sin(kkzz*z(iz)) &
!- kkzz**2 * tanh(5.*(x(ix+ixlg-1)-xl/2.))*cos(kkyy*y(iy))*sin(kkzz*z(iz)) )
!  enddo
! enddo
!enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!ALTERNATIVA PER BOUNDARY CONDITIONS - DA RIVEDERE --------------------------------------------------

do iz = 1, nz
 do ix = 1, nxl
     sy = RHS(ix, :, iz)
     call drfftf(ny, sy, savey)
     RHS(ix, :, iz) = sy
  enddo
enddo

IF (nz.GT.1) THEN
do iy = 1, ny
 do ix = 1, nxl
     sz = RHS(ix, iy, :)
     call drfftf(nz, sz, savez)
     RHS(ix, iy, :) = sz
  enddo
enddo
ENDIF

 CALL traspdist( RHS, Rt, 1 )

do iz = 1, nz
 do iy=1,nyt
  syy1(iy+iylg-1,iz)=Rt(1,iy,iz)
  syy2(iy+iylg-1,iz)=Rt(nx,iy,iz)
 enddo
enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

do iz=1,nz
 do iy=1,nyt

ily=int(0.5*(iy+iytg-1))
IF(ily==ny/2) ily=0

ilz=int(0.5*iz)
IF(ilz==nz/2) ilz=0

  do ix = 2, nx - 1
    g1(ix) = pss_rhs_1(ily,ilz) * (Rt(ix-1,iy,iz) + Rt(ix+1,iy,iz))  &
           + pss_rhs_0(ily,ilz) *  Rt(ix,iy,iz)
  enddo

! Condizioni al contorno
! E = cost (vedi subroutine inizializza, riga 190)
! Imponiamo E = RHS_bordi

 g1(1)	= syy1(iy,iz)
 g1(nx) = syy2(iy,iz)

! Condizioni al contorno
! dE/dx = 0.0 (vedi subroutine inizializza, riga 190)

! g1(1) = 0.0d0
! g1(nx)= 0.0d0

 CALL  DGTTRS(TRNAS,nx,irhs,poiss_m(:,ily,ilz),poiss_d(:,ily,ilz),poiss_p(:,ily,ilz),poiss_w,ipv_p(:,ily,ilz),g1,idb,ifno)

 if (ifno > 0 .or. ifno < 0) then
    write(*,*) 'Problemi soluzione, ifno:', ifno
    stop
 endif

 Rt(:,iy,iz)=g1

 enddo
enddo

 CALL traspdist( RHS, Rt, -1 )
 RHS(:,ny,:)=0.d0
IF (nz.GT.1) THEN
 RHS(:,:,nz)=0.d0
ENDIF

do iz = 1, nz
 do ix = 1, nxl
   sy = RHS(ix, :,iz)
  call drfftb( ny, sy, savey )
   RHS( ix, :, iz) = sy * Tot_inv_ny
 enddo
enddo

IF (nz.GT.1) THEN
do iy = 1, ny
 do ix = 1, nxl
   sz = RHS(ix, iy, :)
  call drfftb( nz, sz, savez )
   RHS( ix, iy, :) = sz * Tot_inv_nz
 enddo
enddo
ENDIF

!test
!Ex=RHS
!call outx

deallocate(g1)
deallocate(sy)
deallocate(sz)
deallocate(syy1)
deallocate(syy2)
deallocate(Rt)

  end subroutine


*
*     ------------------------------------------------------------------
*	M A T M L 4
*     ------------------------------------------------------------------
*
      SUBROUTINE MATML4(C,A,B,NCROW,NCCOL,NAROW,NACOL,
     &                  NBROW,NBCOL,ITRNSP )
C
C MULTIPLY A AND B TO GIVE C
C
C     C = A * B             FOR ITRNSP = 0
C
C     C = A(TRANSPOSED) * B FOR ITRNSP = 1
C
C     C = A * B(TRANSPOSED) FOR ITRNSP = 2
C
C... JEPPE OLSEN, LAST REVISION JULY 24 1987
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NAROW,NACOL),B(NBROW,NBCOL)
      DIMENSION C(NCROW,NCCOL)
C
      NTEST = 0
      IF ( NTEST .NE. 0 ) THEN
        WRITE(6,*)
        WRITE(6,*) ' A AND B MATRIX FROM MATML4 '
        WRITE(6,*)
        CALL WRTMAT(A,NAROW,NACOL,NAROW,NACOL)
        CALL WRTMAT(B,NBROW,NBCOL,NBROW,NBCOL)
        WRITE(6,*)      ' NCROW NCCOL NAROW NACOL NBROW NBCOL '
        WRITE(6,'(6I6)')  NCROW,NCCOL,NAROW,NACOL,NBROW,NBCOL
      END IF
C
      CALL SETVEC(C,0.0D0,NCROW*NCCOL)
C
      IF( ITRNSP .NE. 0 ) GOTO 001
        DO 50 J = 1,NCCOL
          DO 40 K = 1,NBROW
            BKJ = B(K,J)
            DO 30 I = 1, NCROW
              C(I,J) = C(I,J) + A(I,K)*BKJ
  30        CONTINUE
  40      CONTINUE
  50    CONTINUE
C
C
  001 CONTINUE
C
      IF ( ITRNSP .NE. 1 ) GOTO 101
C... C = A(T) * B
         DO 150 J = 1, NCCOL
           DO 140 K = 1, NBROW
             BKJ = B(K,J)
             DO 130 I = 1, NCROW
               C(I,J) = C(I,J) + A(K,I)*BKJ
  130        CONTINUE
  140      CONTINUE
  150    CONTINUE
C
  101 CONTINUE
C
      IF ( ITRNSP .NE. 2 ) GOTO 201
C... C = A*B(T)
        DO 250 J = 1,NCCOL
          DO 240 K = 1,NBCOL
            BJK = B(J,K)
            DO 230 I = 1, NCROW
              C(I,J) = C(I,J) + A(I,K)*BJK
 230        CONTINUE
 240      CONTINUE
 250    CONTINUE
C
C
  201 CONTINUE
C
      IF ( NTEST .NE. 0 ) THEN
        WRITE(6,*)
        WRITE(6,*) ' C MATRIX FROM MATML4 '
        WRITE(6,*)
        CALL WRTMAT(C,NCROW,NCCOL,NCROW,NCCOL)
      END IF
C
      RETURN
      END