!******************************************************************************
!
!    pdoptomog.f95 (part of doptomog package v2.0)
!    Copyright (C) 2015  Enrico J. Kotze ejk@saao.ac.za
!
!    This program is free software: you can redistribute it and/or modify
!    it under the terms of the GNU General Public License as published by
!    the Free Software Foundation, either version 3 of the License, or
!    (at your option) any later version.
!
!    This program is distributed in the hope that it will be useful,
!    but WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!    GNU General Public License for more details.
!
!    You should have received a copy of the GNU General Public License
!    along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!******************************************************************************
program pdoptomog
!******************************************************************************

!******************************************************************************
	use mconstants
	use mfunctions
	use mdoptomog
	implicit none
	
	integer											::	i
	character(len=255)								::	arg

	! current working directory
	call getcwd(cwd)

	! input parameters from command line 
	do i = 1, iargc()
		call getarg(i, arg)
		if (i == 1) read(arg, '(i2)') proj
		if (i == 2) read(arg, '(a)') srcpath
		! ... that's it for now...
	end do
	write (cproj, '(i1)') proj

	! input parameters from 'doptomog.in'
	call inputParameters()

	! input spectra from 'specextract.out'
	call inputSpectra()

	! validate input
	call inputValidate()

	! calculate velocity variables
	call velocityVariables()

	! do Doppler tomography - loop for nr of half phases if necessary
	do i = 0, nhp
		! determine phase extracted stuff
		call phaseExtract(i)

		! calculate projection matrix
		call projectionMatrix()

		! initialise some work variables and arrays
		call initialise()

		! add baseline flux to input spectra
		call baselineFlux()

		! normalise input spectra to constant wavelength-integrated flux
		call spectraNormalised(i)

		! unitise spectra flux values
		call spectraUnitised()

		! construct dopmap
		call dopmapConstructed(i)

		! write output
		call output()

		! calculate flux modulation per pixel (if applicable)
		if (nhp > 0 .and. i == nhp) call fluxModulation()

		! deallocate work arrays
		deallocate(P, indP, ninP, Pt, indPt, ninPt, Psum, indx, indy)
		deallocate(phasep, dphasep, phasebins, sin2piphi, cos2piphi, vplower)
		deallocate(psic, psib, psi0, psi, phip, phib, phiu, phi0, phi)
		deallocate(chi, dHdpsi, dSdpsi, dpsi0, dpsi, dphi0, dphi)
	end do

	! deallocate final work arrays
	deallocate(phase, dphase, vp, phii)

!******************************************************************************
contains
!******************************************************************************

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

!******************************************************************************
	subroutine inputParameters()

		! read input parameters
		integer											::	i

		! input data file
		inpath = trim(srcpath)//'in/'
		open(unit = 1, file = trim(inpath)//'doptomog.in')
		! type of likelihood function (0 = log, 1 = rms)
		read(1, *) iH
		! spectra to be normalised to constant wavelength-integrated light?
		read(1, *) nrm
		! smearing width in default map
		read(1, *) nsw
		! max number of iterations
		read(1, *) nmi
		! print control
		read(1, *) pri
		! accuracy of FME iteration
		read(1, *) acc
		! baseline flux added to spectrum (fraction of average spectrum)
		read(1, *) bfa
		! minimum overall base level added before normalisation
		read(1, *) bfm
		! alpha variable for penalty function
		read(1, *) alf
		! central absorption parameters
		read(1, *) amp
		read(1, *) wid
		! nr of pixels (in one direction)
		read(1, *) np
		! nr of half-phase maps
		read(1, *, end = 5) nhp
	5	continue
		close(1)

		return

	end subroutine inputParameters
!******************************************************************************

!******************************************************************************
	subroutine inputSpectra()

		! read input spectra
		integer											::	i, j, n

		inpath = trim(srcpath)//'out/spectra/'
		open(unit = 1, file = trim(inpath)//'specextract.out')
		! period fold indicator (0 = orbital, 1 = spin)
		read(1, *) pmod
		! velocity scale (to convert to m/s), gamma velocity, rest wavelength, ...
		read(1, *) vs, gam, w0, abl, atm, src
		! nr of phase bins, nr of velocity points
		read(1, *) npb, nvp
		! total nr of velocity entries
		nvt = npb * nvp
		! allocate dimensions to work arrays
		allocate(phase(npb), dphase(npb), vp(nvp), phii(nvt), spec(npb,nvp))
		! centres of phase bins
		read(1, *) (phase(i), i = 1, npb)
		! width of phase bins
		read(1, *) (dphase(i), i = 1, npb)
		! velocity points
		read(1, *) (vp(i), i = 1, nvp)
		! convert to m/s
		vp = vp / vs
		vs = vs / vs
		! spectra flux values
		read(1, *) (phii(i), i = 1, nvt)
!		read(1, *) ((spec(i,j), i = 1, npb), j = 1, nvp)
		close(1)
		! phase index master array (maximum index = # of phase values)
		allocate(pIndexM(0:npb)); pIndexM = 0d0
		do i = 1, npb
			pIndexM(i) = dble(i)
			do j = 1, nvp
				n = i + (j - 1) * npb
				spec(i,j) = phii(n)
!				phii(n) = spec(i,j)
			end do
		end do

		return

	end subroutine inputSpectra
!******************************************************************************

!******************************************************************************
	subroutine inputValidate()

		! smearing width in default map
		if (nsw <= 0) nsw = 4
		! accuracy of FME iteration
		if (acc <= 0d0) acc = 3e-3
		! max no of iterations
		if (nmi <= 0) nmi = 100
		! alfa variable
		if (alf <= 0d0) &
			alf = 0.003 * (dble(np) / nvp)**2 * dble(min(npb, nvp)) / nvp
		! central absorption parameters
		if (wid == 0d0) wid = 2.5e5
		if (wid < 0d0) then
			wid = 1d0; amp = 0d0
		end if
		! write to log
		call outputLog(l0)

		return

	end subroutine inputValidate
!******************************************************************************

!******************************************************************************
	subroutine velocityVariables()

		! determine velocity variables
		! maximum absolute velocity
		vmax = max(abs(vp(1)), vp(nvp))
		! velocity bin width
		dv = 2d0 * vmax / (np - 1)
		! calculate velocity point width
		dvi = (vp(nvp) - vp(1)) / (nvp - 1)
		! "half" nr of pixels
		fv = 0.5d0 * np

		return

	end subroutine velocityVariables
!******************************************************************************

!******************************************************************************
	subroutine phaseExtract(p)

		integer, intent(in)								::	p
		integer, dimension(4)							::	ip
		integer											::	i, j, n, m

		call phaseIndices(p, ip)
		npm = ip(4) - ip(3) + ip(2) - ip(1)
		nvm = npm * nvp
		! allocate dimensions to working phase arrays
		allocate(phasep(npm), dphasep(npm), phip(nvm))
		n = 0
		if (ip(2) > 0) then
			do i = ip(1) + 1, ip(2)
				n = n + 1
				phasep(n) = phase(i)
				dphasep(n) = dphase(i)
				do j = 1, nvp
					m = n + (j - 1) * npm
					phip(m) = spec(i,j)
				end do
			end do
		end if
		do i = ip(3) + 1, ip(4)
			n = n + 1
			phasep(n) = phase(i)
			dphasep(n) = dphase(i)
			do j = 1, nvp
				m = n + (j - 1) * npm
				phip(m) = spec(i,j)
			end do
		end do

		return

	end subroutine phaseExtract
!******************************************************************************

!******************************************************************************
	subroutine projectionMatrix()

		! projection matrix
		real(kind(1d0))									::	vx, vy
		integer											::	i, j, ix, iy, ir

		! total nr of map points
		nmt = int(PI * (0.25 * np**2 - 0.335 * np + 0.09))
		! allocate dimensions to work arrays
		allocate(P(nvm,nmt), indP(nvm,nmt), ninP(nvm))
		allocate(Pt(nmt,nvm), indPt(nmt,nvm), ninPt(nmt))
		allocate(Psum(nmt), indx(nmt), indy(nmt))
		! initialise forward and backward projection matrices, as well as index
		! arrays: ninP, ninPt, indP, indPt, indx and indy
		P = fmin; Pt = fmin; ninP = 0; ninPt = 0; indP = 0; indPt = 0
		indx = 0; indy = 0; Psum = 0d0
		! reset pixel counter
		ir = 0
		! sin and cos tables for lower, centre and upper edges of phase bins
		call phaseTables()
		! lower edges of velocity bins
		call velocityBins()
		! loop through velocity space
		do ix = 1, np
			! x-velocity grid defined: min and max of vx = (-vmax, vmax)
			vx = dv * (ix - fv - 0.5d0)
			do iy = 1, np
				! y-velocity grid defined: min and max of vy = (-vmax, vmax)
				vy = dv * (iy - fv - 0.5d0)
				! use only points inside circle of radius (vmax + 0.1dv)
				if (vx**2 + vy**2 < (vmax + 0.1d0 * dv)**2) then
					! determine projection matrix entry
					call projectionMatrixEntry(ix, iy, ir, vx, vy)
				end if
			end do
		end do
		nm = ir
		call projectionMatrixNormalised()

		return

	end subroutine projectionMatrix
!******************************************************************************

!******************************************************************************
	subroutine initialise()

		! allocate dimensions to work arrays
		allocate(psic(nm,4), psib(nm), psi0(nm), psi(nm))
		allocate(phib(nvm), phiu(nvm), phi0(nvm), phi(nvm))
		allocate(chi(nm), dHdpsi(nm), dSdpsi(nm))
		allocate(dpsi0(nm), dpsi(nm), dphi0(nvm), dphi(nvm))
		! "change" maps
		psic = 0d0
		! baseline map
		psib = 0d0
		! starting and "working" maps
		psi0 = 0d0; psi = 0d0
		! delta maps
		dpsi0 = 0d0; dpsi = 0d0
		! H and S derivative maps
		dHdpsi = 0d0; dSdpsi = 0d0
		! default map
		chi = 0d0
		! starting and "working" spectra flux values
		phi0 = 0d0; phi = 0d0
		! delta spectra flux values
		dphi0 = 0d0; dphi = 0d0

		return

	end subroutine initialise
!******************************************************************************

!******************************************************************************
	subroutine baselineFlux()

		! calculate baseline flux to get a flat background level in dopmap:
		! phib is the data corresponding to a flat (circular) dopmap
		! psib is the corresponding flat dopmap
		integer											::	i, j, ix, iy, ip
		real(kind(1d0))									::	vx, vy, d0, bf

		! initialise baseline spectra flux values
		phib = 0d0
		! flat background
		psib = 1d0
		! produce spectrum (phib) from psib
		call projectForward(psib, phib)
		! calculate baseline flux to add, i.e., bfa * average of input spectra
		bf = bfa * sum(phii) / nvt
		! value at v = 0
		d0 = phib(npm * nvp / 2)
		! normalise phib
		phib = phib * bf / d0
		! normalise background map
		psib = psib * bf / d0
		! add baseline to phii
		do i = 1, nvm
			phip(i) = phip(i) + phib(i)
			if (phip(i) < bf / 3d0) phip(i) = 1e-5 * bf
		end do

		return

	end subroutine baselineFlux
!******************************************************************************

!******************************************************************************
	subroutine spectraNormalised(p)

		! normalise by a phase-dependent factor to make wavelength-integrated
		! light constant with phase
		integer, intent(in)								::	p
		real(kind(1d0)), dimension(npm)					::	phisum
		real(kind(1d0))									::	phimin, bs
		integer											::	i, j, n

		if (nrm == 1 .and. p == 0) then
			phisum = 0d0; bs = 0d0
			! get sum
			do i = 1, npm
				do j = 1, nvp
					n = i + (j - 1) * npm
					phisum(i) = phisum(i) + phip(n)
				end do
			end do
			phisum = npm * phisum / sum(phisum)
			! get minimum of phisum
			phimin = minval(phisum)
			! set an overall base level to be added before normalisation
			if (phimin < bfm) bs = bfm - phimin
			! normalise spectra
			do i = 1, npm
				if (phisum(i) /= 0d0) then
					do j = 1, nvp
						n = i + (j - 1) * npm
						phip(n) = phip(n) * (1d0 + bs) / (phisum(i) + bs)
					end do
				end if
			end do
			! update spec array
			do i = 1, npm
				do j = 1, nvp
					n = i + (j - 1) * npm
					spec(i,j) = phip(n)
				end do
			end do
		end if

		return

	end subroutine spectraNormalised
!******************************************************************************

!******************************************************************************
	subroutine spectraUnitised()

		! unitising spectra flux values
		integer											::	i, j, n

		! initialise unitising spectra flux values
		phiu = 1d0
		! override values for zero baseline
		do i = 1, npm
			do j = 1, nvp
				n = i + (j - 1) * npm
				if (phib(n) == 0d0) phiu(n) = 0d0
			end do
		end do
		! normalise to average = 1
		phiu = npm * phiu / sum(phiu)

		return

	end subroutine spectraUnitised
!******************************************************************************

!******************************************************************************
	subroutine dopmapConstructed(p)

		! process model with alfa = alf,
		! converged to accuracy acc with Lucy's fast ME scheme
		integer, intent(in)								::	p

		! initialise quality function values, convergence measure
		Q = 0d0; Q0 = 0d0; del = 1d0
		! initialise return code and iterations counter
		ierr = 0; ni = 0
		! initialise starting map: psi0
		psi0 = sum(phip) / nm
		! copy starting map into "working" map: psi
		psi = psi0
		! loop until converged or max nr iterations reached
		do while (del > acc .and. ni < nmi)
			ni = ni + 1
			! process iteration
			call fmeIteration(); if (ierr == 4) exit
		end do
		! reconstruct "working" spectra
		call projectForward(psi, phi)
		! validate nr of iterations
		if (ni >= nmi) ierr = ierr + 1	! not converged
		! write log - summaries
		call outputLog(l2, append=1)
		! update starting map and spectra
		psi0 = psi; phi0 = phi
		! "clean" central velocity bins (if applicable)
		call centralVelocityBins()
		! add half phase work arrays to total arrays (if applicable)
		call totalArrays(p)

		return

	end subroutine dopmapConstructed
!******************************************************************************

!******************************************************************************
	subroutine output()

		! write output
		real(kind(1d0)), dimension(np,np)				::	map, dmap
		integer											::	i, j, k

		outpath = trim(srcpath)//'out/doptomog/'
		open(unit = 1, file = trim(outpath)//'doptomog.'//cproj//trim(chp)//'.out')
		! max velocity, m to 10**3 km factor, nr of pixels,
		! period fold indicator, projection type
		write(1, '(es14.6, es10.2, i5, 2i3)') vmax, vf, np, pmod, proj
		! input spectra, array sizes
		write(1, '(i3, i6, 2i5, " input spectra ")') 1, nvm, npm, nvp
		! input spectra parameters
		write(1, '(2es10.2, f10.2, 2i3, a)') vs, gam, w0, abl, atm, &
			'  '//trim(src)
		! phase coordinates of input spectra
		write(1, '(1p6es14.6)') (twoPI * phasep(i), i = 1, npm)
		write(1, '(1p6es14.6)') (twoPI * dphasep(i), i = 1, npm)
		! velocity coordinates of input spectra
		write(1, '(1p6es14.6)') (vp(i), i = 1, nvp)
		! flux values of input spectra
		write(1, '(1p6es14.6)') (phip(i) - phib(i), i = 1, nvm)
		! reconstructed spectra
		write(1, '(i3, i6, " reconstructed spectra ")') 1, nvm
		! flux values of reconstructed spectra
		write(1, '(1p6es14.6)') (phi0(i) - phib(i), i = 1, nvm)
		! dopmap, array sizes
		write(1, '(i3, i6, i5," dopmap ")') 1, nm, np
		! dopmap parameters
		write(1, '(3i3, 4es10.3)') iH, nrm, nsw, alf, wid, amp, acc
		! unfold dopmap image: 1D to 2D
		map = 0d0
		do j = 1, nm
			map(indx(j),indy(j)) = psi0(j) - psib(j)
		end do
		! dopmap
		write(1, '(1p6es14.6)') ((map(i,j), j = 1, np), i = 1, np)
		! delta maps
		write(1, '(i3, " delta maps ")') 4
		do k = 1, 4
			! use dmap to unfold change maps: 1D to 2D
			dmap = 0d0
			do j = 1, nm
				dmap(indx(j),indy(j)) = psic(j,k)
			end do
			write(1, '(1p6es14.6)') ((dmap(i,j), j = 1, np), i = 1, np)
		end do
		! modulation maps
		write(1, '(i3, '' modulation maps '')') 0
		close(1)

		return

	end subroutine output
!******************************************************************************

!******************************************************************************
	subroutine fluxModulation()

		integer									::	i, j

		! allocate work arrays
		allocate(tphase(nhp), gs(nhp), fs(nhp))
		tphase = 0d0; gs = 0d0; fs = 0d0
		allocate(mamp(nm), mpha(nm), mavg(nm))
		mamp = 0d0; mpha = 0d0; mavg = 0d0

		! loop through flux modulation pixel map
		do j = 1, nm
			do i = 1, nhp
				tphase(i) = mod(0.25d0 + float(i - 1) / float(nhp), 1d0)
				gs(i) = mpix(j,i)
			end do
			! determine flux modulation fit
			call fluxModulationFit(j)
		end do

		! update flux modulation
		call fluxModulationUpdate()

		! output flux modulation
		call fluxModulationOutput()

		! deallocate work arrays
		deallocate(tphii, tphi0, tphase)
		deallocate(tpsi, tpsic, mpix)
		deallocate(gs, fs, mavg, mamp, mpha, mpham)

		return

	end subroutine fluxModulation
!******************************************************************************

!******************************************************************************
	subroutine fluxModulationFit(j)

		! determine data fit with multi-variate least squares
		integer, intent(in)						::	j
		integer									::	i
		real(kind(1d0)), dimension(0:2)			::	as

		! sine fitting:
		as = 0d0
		! calculate a0 - average
		as(0) = sum(gs) / float(nhp)
		! calculate f(i)
		do i = 1, nhp
			! calculate f(i)
			fs(i) = gs(i) - as(0)
			! calcualte a1 - sin(PHI(i)) coefficient
			as(1) = as(1) + fs(i) * sin(twoPI * tphase(i))
			! calcualte a2 - cos(PHI(i)) coefficient
			as(2) = as(2) + fs(i) * cos(twoPI * tphase(i))
		end do
		as(1) = 2d0 * as(1) / float(nhp)
		as(2) = 2d0 * as(2) / float(nhp)
		! calculate amplitude, phase-offset and average, and write to maps
		mamp(j) = sqrt(as(1)**2 + as(2)**2)
		mpha(j) = atan(-1d0 * as(2) / as(1)) / twoPI
		if (as(1) < 0d0) mpha(j) = mpha(j) + 0.5d0
		mavg(j) = as(0)

		return

	end subroutine fluxModulationFit
!******************************************************************************

!******************************************************************************
	subroutine fluxModulationUpdate()

		integer									::	j
		real(kind(1d0))							::	mintot, maxtot
		real(kind(1d0))							::	minavg, maxavg
		real(kind(1d0))							::	minamp, maxamp

		allocate(mpham(nm))
		mpham = 0d0
		! min and max values
		mintot = minval(tpsi); maxtot = maxval(tpsi)
		minamp = minval(mamp); maxamp = maxval(mamp)
		minavg = minval(mavg); maxavg = maxval(mavg)
		! phase of max flux: phase-offset + 0.25
		mpham = mpha + 0.25d0
		! loop through pixel modulation map
		do j = 1, nm
			! normalise total, amplitude and average maps between 0 and 1
			tpsi(j) = (tpsi(j) - mintot) / (maxtot - mintot)
			mamp(j) = (mamp(j) - minamp) / (maxamp - minamp)
			mavg(j) = (mavg(j) - minavg) / (maxavg - minavg)
		end do

		! average totalled spectra
		tphii = tphii / float(nhp)
		tphi0 = tphi0 / float(nhp)

		return

	end subroutine fluxModulationUpdate
!******************************************************************************

!******************************************************************************
	subroutine fluxModulationOutput()

		! write output
		real(kind(1d0)), dimension(np,np)				::	map, dmap, mmap
		integer											::	i, j, k

		open(unit = 1, file = trim(outpath)//'fluxmodmap.'//cproj//'.out')
		! max velocity, m to 10**3 km factor, nr of pixels,
		! period fold indicator, projection type
		write(1, '(es14.6, es10.2, i5, 2i3)') vmax, vf, np, pmod, proj
		! input spectra, array sizes
		write(1, '(i3, i6, 2i5, " input spectra ")') 1, nvt, npb, nvp
		! input spectra parameters
		write(1, '(2es10.2, f10.2, 2i3, a)') vs, gam, w0, abl, atm, &
			'  '//trim(src)
		! phase coordinates of input spectra
		write(1, '(1p6es14.6)') (twoPI * phase(i), i = 1, npb)
		write(1, '(1p6es14.6)') (twoPI * dphase(i), i = 1, npb)
		! velocity coordinates of input spectra
		write(1, '(1p6es14.6)') (vp(i), i = 1, nvp)
		! flux values of input spectra
		write(1, '(1p6es14.6)') (tphii(i), i = 1, nvt)
		! reconstructed spectra
		write(1, '(i3, i6, " reconstructed spectra ")') 1, nvt
		! flux values of reconstructed spectra
		write(1, '(1p6es14.6)') (tphi0(i), i = 1, nvt)
		! dopmap, array sizes
		write(1, '(i3, i6, i5," dopmap ")') 1, nm, np
		! dopmap parameters
		write(1, '(3i3, 4es10.3)') iH, nrm, nsw, alf, wid, amp, acc
		! unfold dopmap image: 1D to 2D
		map = 0d0
		do j = 1, nm
			map(indx(j),indy(j)) = tpsi(j)
		end do
		! dopmap
		write(1, '(1p6es14.6)') ((map(i,j), j = 1, np), i = 1, np)
		! delta maps
		write(1, '(i3, " delta maps ")') 4
		do k = 1, 4
			! use dmap to unfold change maps: 1D to 2D
			dmap = 0d0
			do j = 1, nm
				dmap(indx(j),indy(j)) = tpsic(j,k)
			end do
			write(1, '(1p6es14.6)') ((dmap(i,j), j = 1, np), i = 1, np)
		end do
		! modulation maps
		write(1, '(i3, '' modulation maps '')') 4
		! unfold modulation average map image: 1D to 2D
		mmap = 0d0
		do j = 1, nm
			mmap(indx(j),indy(j)) = mavg(j)
		end do
		! average map
		write(1, '(1p6es14.6)') ((mmap(i,j), j = 1, np), i = 1, np)
		! unfold modulation amplitude map image: 1D to 2D
		mmap = 0d0
		do j = 1, nm
			mmap(indx(j),indy(j)) = mamp(j)
		end do
		! amplitude map
		write(1, '(1p6es14.6)') ((mmap(i,j), j = 1, np), i = 1, np)
		! unfold modulation phase-offset map image: 1D to 2D
		mmap = 99.9d0
		do j = 1, nm
			mmap(indx(j),indy(j)) = mpha(j)
		end do
		! phase-offset map
		write(1, '(1p6es14.6)') ((mmap(i,j), j = 1, np), i = 1, np)
		! unfold modulation phase of max flux map image: 1D to 2D
		mmap = 99.9d0
		do j = 1, nm
			mmap(indx(j),indy(j)) = mpham(j)
		end do
		! phase of max flux map
		write(1, '(1p6es14.6)') ((mmap(i,j), j = 1, np), i = 1, np)
		close(1)

		return

	end subroutine fluxModulationOutput
!******************************************************************************

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

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

!******************************************************************************
	subroutine phaseIndices(p, ip)

		integer, intent(in)								::	p
		integer, dimension(4), intent(out)				::	ip
		real(kind(1d0)), dimension(0:4)					::	pIndex
		real(kind(1d0)), dimension(4)					::	pRange
		real(kind(1d0))									::	pStep
		character(len=10)								::	acf = ''
		character(len=20)								::	pphase = ''

		ip = 0; pRange = 0d0
		if (p == 0) then
			chp = ''
			ip(4) = npb
			write(pphase, '(f5.3, " - ", f5.3)') 0.0, 1.0
		else
			pStep = 1d0 / dble(nhp)
			! write output file chp (i.e., which half-phase)
			write(chp, '(i3)') p - 1
			chp = '.'//trim(adjustl(chp))
			! write halfphases output (if any) to 'halfphases.out'
			if (p == 1) acf = 'sequential'
			if (p > 1) acf = 'append'
			open(unit = 1, file = trim(outpath)//'halfphases.'//cproj//'.out', &
				access = trim(acf))
			if (p == 1) write(1, '(i3)') nhp
			! determine half phase range
			if (pStep * (p - 1) < 0.5d0) then
				pRange(3) = pStep * (p - 1)
				pRange(4) = pStep * (p - 1) + 0.5d0
				write(1, '(2f10.4)') pRange(3), pRange(4)
				write(pphase, '(f5.3, " - ", f5.3)') pRange(3), pRange(4)
			else
				pRange(2) = pStep * (p - 1) - 0.5d0
				pRange(3) = pStep * (p - 1)
				pRange(4) = 1d0
				write(1, '(2f10.4)') pRange(3), pRange(2)
				write(pphase, '(f5.3, " - ", f5.3)') pRange(3), pRange(2)
			end if
			close(1)
			! interpolate phase indices for specified half phase range
			call interpolate(phase, pIndexM, npb, pRange, pIndex, 4)
			ip(1) = int(pIndex(1))
			ip(2) = int(pIndex(2))
			ip(3) = int(pIndex(3))
			ip(4) = int(pIndex(4))
			if (ip(3) > 0 .and. ip(4) == 0) ip(4) = ip(4) + npb
		end if
		! write to log
		call outputLog(l0, append=1, pphase=pphase)

		return

	end subroutine phaseIndices
!******************************************************************************

!******************************************************************************
	subroutine phaseTables()

		! lower, centre and upper edges of phase bins, as well as
		! sin and cos tables for lower, centre and upper edges of phase bins
		integer											::	i

		! allocate dimensions to work arrays
		allocate(phasebins(npm,3), sin2piphi(npm,3), cos2piphi(npm,3))
		do i = 1, 3
			phasebins(1:npm,i) = twoPI * (phasep + dble(i - 2) * 0.5d0 * dphasep)
			! sin tables for lower, centre and upper edges of phase bins
			sin2piphi(1:npm,i) = sin(phasebins(1:npm,i))
			! cos tables for lower, centre and upper edges of phase bins
			cos2piphi(1:npm,i) = cos(phasebins(1:npm,i))
		end do

		return

	end subroutine phaseTables
!******************************************************************************

!******************************************************************************
	subroutine velocityBins()

		! calculate lower edges of velocity bins
		integer											::	i

		! allocate dimensions to work arrays
		allocate(vplower(-1:nvp+2))
		do i = 1, nvp - 1
			vplower(i+1) = 0.5d0 * (vp(i) + vp(i+1))
		end do
		vplower(1) = vp(1) - 0.5d0 * (vp(2) - vp(1))
		vplower(nvp+1) = vp(nvp) + 0.5d0 * (vp(nvp) - vp(nvp-1))
		vplower(0) = vplower(1) - (vplower(2) - vplower(1))
		vplower(-1) = -10d0 * vmax
		vplower(nvp+2) = 10d0 * vmax

		return

	end subroutine velocityBins
!******************************************************************************

!******************************************************************************
	subroutine projectionMatrixEntry(ix, iy, ir, vx, vy)

		integer, intent(in)								::	ix, iy
		integer, intent(out)							::	ir
		real(kind(1d0)), intent(in)						::	vx, vy
		real(kind(1d0))									::	vphi, v, vp0, vp1
		real(kind(1d0))									::	vpmin, vpmax
		integer											::	ip, iv, kmin, kmax

		! increase pixel count
		ir = ir + 1
		if (ir > nmt) call outputLog(l3, args='"ir > nmt: "', argi=(/ir, nmt/))
		! set xy indices
		indx(ir) = ix; indy(ir) = iy
		! calculate projection velocity
		! determine polar velocity coordinates
		call polarCoords(vx, vy, vphi, v)
		! if inside-out projection... inside-out polar velocity coordinates
		if (proj > 0) call inoutCoords(vmax, dv, v, v)
		! loop through phases
		do ip = 1, npm
			! calculate line-of-sight velocity at phase bin edges
			call losVelocity(ir, ip, vphi, v, vpmin, vpmax)
			! calculate indices of line-of-sight bins
			call losIndices(vpmin, vpmax, kmin, kmax)
			! loop between kmin and kmax
			do iv = kmin, kmax
				! calculate projection element
				call projectionElement(ir, ip, iv, vpmin, vpmax)
			end do
		end do

		return

	end subroutine projectionMatrixEntry
!******************************************************************************

!******************************************************************************
	subroutine losVelocity(ir, ip, vphi, v, vpmin, vpmax)

		! determine line-of-sight velocity at phase bin edges
		integer, intent(in)								::	ir, ip
		real(kind(1d0)), intent(in)						::	vphi, v
		real(kind(1d0)), intent(out)					::	vpmin, vpmax
		real(kind(1d0))									::	vp0, vp1, vpc

		vpc = v * sin(phasebins(ip,centre) - vphi)
		vp0 = v * sin(phasebins(ip,lower) - vphi)
		vp1 = v * sin(phasebins(ip,upper) - vphi)
		if (vp0 > vp1) then
			vpmin = vp1 - 0.5d0 * dv
			vpmax = vp0 + 0.5d0 * dv
		else
			vpmin = vp0 - 0.5d0 * dv
			vpmax = vp1 + 0.5d0 * dv
		end if
		if (vpmin < vplower(-1)) call outputLog(l3, &
									args='"vpmin < vplower(-1): "', &
									argr=(/vpmin, vplower(-1)/))
		if (vpmax > vplower(nvp+2)) call outputLog(l3, &
									args='"vpmax > vplower(nvp+2): "', &
									argr=(/vpmax, vplower(nvp+2)/))

		return

	end subroutine losVelocity
!******************************************************************************

!******************************************************************************
	subroutine losIndices(vpmin, vpmax, kmin, kmax)

		! determine indices of line-of-sight bins for vpmin and vpmax
		real(kind(1d0)), intent(in)						::	vpmin, vpmax
		integer, intent(out)							::	kmin, kmax

		kmin = (vpmin - vplower(1)) / dvi + 1
		kmax = (vpmax - vplower(1)) / dvi + 1
		kmin = max(0, kmin)
		kmin = min(kmin, nvp + 1)
		kmax = min(kmax, nvp + 1)
		kmax = max(0, kmax)
		! get first vplower(i) < vpmin
		if (vplower(kmin) < vpmin) then
			do while (vplower(kmin+1) < vpmin)
				kmin = kmin + 1
			end do
		else
			do while (vplower(kmin-1) > vpmin)
				kmin = kmin - 1
			end do
		end if
		! get first vplower(i) < vpmax
		if (vplower(kmax) < vpmax) then
			do while (vplower(kmax+1) < vpmax)
				kmax = kmax + 1
			end do
		else
			do while (vplower(kmax-1) > vpmax)
				kmax = kmax - 1
			end do
		end if
		kmin = max(1, kmin)
		kmax = min(kmax, nvp)

		return

	end subroutine losIndices
!******************************************************************************

!******************************************************************************
	subroutine projectionElement(ir, ip, iv, vpmin, vpmax)

		! calculate projection element
		integer, intent(in)								::	ir, ip, iv
		real(kind(1d0)), intent(in)						::	vpmin, vpmax
		real(kind(1d0))									::	x0, x1, w, vpa, vfa
		integer											::	inp, ict, icp

		! determine contribution factor
		x0 = (vplower(iv) - vpmin) / (vpmax - vpmin)
		x1 = (vplower(iv+1) - vpmin) / (vpmax - vpmin)
		w = dist(x1) - dist(x0)
		! apply central absorption fudge
		vpa = 0.5d0 * (vpmax + vpmin)
		vfa = 1d0 + amp * exp(-min((vpa / wid)**2, 50d0))
		w = w / vfa
		! compute index of this phase-velocity point in data array
		inp = ip + (iv - 1) * npm
		! up counter for P of number of hits in this bin
		icp = ninP(inp) + 1
		if (icp > nmt) call outputLog(l3, &
							args='"projection matrix too small, icp > nmt: "', &
							argi=(/icp, nmt/))
		ninP(inp) = icp
		! store matrix element and save reconstruction index
		P(inp,icp) = w
		indP(inp,icp) = ir
		! up counter for Pt of number of hits in this bin
		ict = ninPt(ir) + 1
		if (ict > nvm) call outputLog(l3, &
							args='"projection matrix too small, ict > nvm: "', &
							argi=(/ict, nvm/))
		ninPt(ir) = ict
		! store transpose element and save data index
		Pt(ir,ict) = w
		indPt(ir,ict) = inp
		! sum contribution factors
		Psum(ir) = Psum(ir) + P(inp,icp)

		return

	end subroutine projectionElement
!******************************************************************************

!******************************************************************************
	subroutine projectionMatrixNormalised()

		! normalise P, Pt
		integer											::	i, j, n, m

		do j = 1, nm
			n = ninPt(j)
			Pt(j,1:n) = Pt(j,1:n) / Psum(j)
		end do
		do i = 1, nvm
			m = ninP(i)
			do j = 1, m
				n = indP(i,j)
				P(i,j) = P(i,j) / Psum(n)
			end do
		end do

		return

	end subroutine projectionMatrixNormalised
!******************************************************************************

!******************************************************************************
	subroutine fmeIteration()

		! determine optimum direction and update factor from dpsi0 and dpsi
		! reconstruct "working" spectra
		call projectForward(psi, phi)
		! calculate quality function Q
		call qualityFunction()
		! new delta map: dpsi
		dpsi = psi * (dHdpsi + alf * dSdpsi); if (ni == 1) dpsi0 = dpsi
		! derivatives of Q w.r.t. to lambda and mu at current psi: fla, fmu
		call acceleration(); if (ierr == 4) return
		! calculate direction and update psi
		call accelerationApplied()
		! measure convergence
		call convergence()
		! write log
		call outputLog(l1, append=1)
		! re-normalise psi (mostly to strip accumulating numerical noise)
		psi = psi * sum(phip) / sum(psi)

		return

	end subroutine fmeIteration
!******************************************************************************

!******************************************************************************
	subroutine centralVelocityBins()

		! "clean" central velocity bins (if applicable)
		integer											::	j, k
		real(kind(1d0))									::	psimin

		if (proj > 0) then
			psimin = minval(psi0)
			k = np / 2
			do j = 1, nm
				if (indx(j) >= 1 - mc + k .and. indx(j) <= mc + k .and. &
				  indy(j) >= 1 - mc + k .and. indy(j) <= mc + k) then
				  	psi0(j) = psimin
				end if
			end do
		end if

		return

	end subroutine centralVelocityBins
!******************************************************************************

!******************************************************************************
	subroutine totalArrays(p)

		! add work arrays to output arrays
		integer, intent(in)						::	p
		integer									::	i, j, k, m, n

		if (p > 0) then
			! allocate dimension to total arrays
			if (p == 1) then
				allocate(tphii(nvt), tphi0(nvt)); tphii = 0d0; tphi0 = 0d0
				allocate(tpsi(nm), tpsic(nm,4)); tpsi = 0d0; tpsic = 0d0
				allocate(mpix(nm,nhp)); mpix = 0d0
			end if
			! spectra
			do k = 1, npb
				do i = 1, npm
					if (phase(k) == phasep(i)) then
						! total input and reconstructed spectra
						do j = 1, nvp
							m = k + (j - 1) * npb
							n = i + (j - 1) * npm
							tphii(m) = tphii(m) + (phip(n) - phib(n))
							tphi0(m) = tphi0(m) + (phi0(n) - phib(n))
						end do
					end if
				end do
			end do
			! maps
			do j = 1, nm
				! total dopmap
				tpsi(j) = tpsi(j) + (psi0(j) - psib(j))
				! delta dopmaps
				do k = 1, 4
					tpsic(j,k) = tpsic(j,k) + psic(j,k)
				end do
				! flux modulation pixel map
				if ((psi0(j) - psib(j)) /= 0d0) mpix(j,p) = psi0(j) - psib(j)
			end do
		end if

		return

	end subroutine totalArrays
!******************************************************************************

!******************************************************************************
	subroutine qualityFunction()

		! quality function Q
		! H and dH/dpsi
		call likelihood()
		! S and dS/dpsi
		call entropy()
		! save old value of Q
		Q0 = Q
		! current value of Q
		Q = H + alf * S
		! warning if not monotonic
		if (ni /= 1 .and. Q < Q0) ierr = 2

		return

	end subroutine qualityFunction
!******************************************************************************

!******************************************************************************
	subroutine likelihood()

		! likelihood part of quality function Q
		! likelihood function H and its derivative w.r.t. psi, dH/dpsi
		! dHdsp = delta-H spectra flux values
		real(kind(1d0)), dimension(nvm)					::	dHdphi
		integer											::	i

		H = 0d0
		dHdphi = 0d0
		if (iH == 0) then
			! log likelihood - H
			do i = 1, nvm
				if (phi(i) > 0d0) then
					! log likelihood - H
					H = H + phiu(i) * (phip(i) * log(phi(i)) - phi(i))
					! derivative w.r.t. to phi, dH/dphi
					dHdphi(i) = phiu(i) * (phip(i) / phi(i) - 1d0)
				end if
			end do
		else
			! rms likelihood - H
			H = nvm * sum(-1d0 * phiu * (phip - phi)**2)
			! derivative w.r.t. to phi, dH/dphi
			dHdphi = 2d0 * nvm * phiu * (phip - phi)
		end if
		! derivative w.r.t. to psi, dH/dpsi
		call projectBackward(dHdphi, dHdpsi)
		! delta-H (in same array as dHdpsi)
		dHdpsi = dHdpsi + (sum(phip) - sum(psi * dHdpsi)) / sum(psi) - 1d0

		return

	end subroutine likelihood
!******************************************************************************

!******************************************************************************
	subroutine entropy()

		! entropy part of quality function Q
		! entropy function S and its derivative w.r.t. psi, dS/dpsi
		! dpsi = (psi - chi) / chi
		real(kind(1d0)), dimension(nm) 					::	dpsi, dchi

		dpsi = 0d0; dchi = 0d0
		! get chi's
		call defaultMap(psi, chi)
		! entropy - S
		S = sum(psi - chi - psi * log(psi / chi))
		! derivative w.r.t. to psi, first the psi*log(psi) part
!		dSdpsi = -1d0 * log(psi / chi)
		dSdpsi = 1d0 - log(psi / chi)
		! add terms due to dependence of chi on psi
		dpsi = (psi - chi) / chi
		! get dchi's
		call defaultMap(dpsi, dchi)
		dSdpsi = dSdpsi + dchi
		! delta-S (in same array as dSdpsi)
		dSdpsi = dSdpsi - sum(psi * dSdpsi) / sum(psi)

		return

	end subroutine entropy
!******************************************************************************

!******************************************************************************
	subroutine acceleration()

		! calculate optimal acceleration variables lambda and mu from 1st and
		! 2nd derivatives of Q
		real(kind(1d0)), dimension(0:4)					::	dQ, dH, dS
		real(kind(1d0))									::	dd, dr

		! likelihood terms
		call accelerationLikelihoodTerms(dH)
		! entropy terms
		call accelerationEntropyTerms(dS)
		! quality function terms
		dQ = dH + alf * dS
		! calculate lambda and mu
		dd = dQ(dl2) * dQ(dm2) - dQ(dldm)**2
		dr = abs(dd) / (dQ(dl2)**2 + dQ(dm2)**2)
		! if det of 2x2 system too small, use only mu
		if (dr < 1e-3) then
			fla = 0d0
			fmu = -dQ(dm) / dQ(dm2)
		else
			fla = (dQ(dm) * dQ(dldm) - dQ(dl) * dQ(dm2)) / dd
			fmu = (dQ(dl) * dQ(dldm) - dQ(dm) * dQ(dl2)) / dd
		end if
		! additional acceleration multiplier mu: amu
		call accelerationAdditional()
		! check if amu has been small for awhile
		call accelerationCheck()

		return

	end subroutine acceleration
!******************************************************************************

!******************************************************************************
	subroutine accelerationLikelihoodTerms(dH)

		real(kind(1d0)), dimension(0:4), intent(out)	::	dH
		integer											::	i

		! get spectra from dpsi0, dpsi
		call projectForward(dpsi0, dphi0)
		call projectForward(dpsi, dphi)
		! first and second derivatives
		dH = 0d0
		if (iH == 0) then
			! log likelihood terms
			do i = 1, nvm
				if (phi(i) > 0d0) then
					dH(dl) = dH(dl) + dphi0(i) * phiu(i) * &
						(phip(i) / phi(i) - 1d0)
					dH(dm) = dH(dm) + dphi(i) * phiu(i) * &
						(phip(i) / phi(i) - 1d0)
					dH(dl2) = dH(dl2) - phiu(i) * phip(i) * &
						(dphi0(i) / phi(i))**2
					dH(dm2) = dH(dm2) - phiu(i) * phip(i) * &
						(dphi(i) / phi(i))**2
					dH(dldm) = dH(dldm) - phiu(i) * phip(i) * &
						(dphi0(i) / phi(i)) * (dphi(i) / phi(i))
				end if
			end do
		else
			! rms likelihood terms
			dH(dl) = nvm * sum(2d0 * phiu * (phip - phi) * dphi0)
			dH(dm) = nvm * sum(2d0 * phiu * (phip - phi) * dphi)
			dH(dl2) = nvm * sum(-2d0 * phiu * dphi0**2)
			dH(dm2) = nvm * sum(-2d0 * phiu * dphi**2)
			dH(dldm) = nvm * sum(-2d0 * phiu * dphi0 * dphi)
		end if

		return

	end subroutine accelerationLikelihoodTerms
!******************************************************************************

!******************************************************************************
	subroutine accelerationEntropyTerms(dS)

		real(kind(1d0)), dimension(0:4), intent(out)	::	dS
		real(kind(1d0)), dimension(0:4)					::	dt
		real(kind(1d0)), dimension(0:1)					::	dP
		real(kind(1d0)), dimension(nm)					::	dchi0, dchi
		real(kind(1d0))									::	Pj
		integer											::	j

		dchi0 = 0d0; dchi = 0d0
		! changes in chi corresponding to dpsi0, dpsi
		call defaultMap(dpsi0, dchi0)
		call defaultMap(dpsi, dchi)
		! first and second derivatives
		dt = 0d0; dP = 0d0; dS = 0d0
		! entropy terms
		do j = 1, nm
			dt(dl) = dchi0(j) / chi(j); dt(dm) = dchi(j) / chi(j)
			dt(dl2) = dt(dl)**2; dt(dm2) = dt(dm)**2; dt(dldm) = dt(dl) * dt(dm)
			dP(dl) = dpsi0(j) / psi(j); dP(dm) = dpsi(j) / psi(j)
			Pj = psi(j) - chi(j)
			dS(dl) = dS(dl) - dpsi0(j) * log(psi(j) / chi(j)) + Pj * dt(dl)
			dS(dm) = dS(dm) - dpsi(j) * log(psi(j) / chi(j)) + Pj * dt(dm)
			dS(dl2) = dS(dl2) - psi(j) * (dP(dl) - dt(dl))**2 + &
				Pj * (dt(dl)**2 - dt(dl2))
			dS(dm2) = dS(dm2) - psi(j) * (dP(dm) - dt(dm))**2 + &
				Pj * (dt(dm)**2 - dt(dm2))
			dS(dldm) = dS(dldm) - psi(j) * (dP(dl) - dt(dl)) * &
				(dP(dm) - dt(dm)) + Pj * (dt(dl) * dt(dm) - dt(dldm))
		end do

		return

	end subroutine accelerationEntropyTerms
!******************************************************************************

!******************************************************************************
	subroutine accelerationAdditional()

		! calculate additional multiplier mu
		real(kind(1d0))									::	lamu, flm
		integer											::	j

		lamu = 0d0; flm = 0d0
		! length of multiplier
		amu = sqrt(fla**2 + fmu**2)
		! direction (normalised) of optimum
		fla = fla / amu
		fmu = fmu / amu
		! determine limit for amu
		do j = 1, nm
			! value of prospective update
			lamu = fla * dpsi0(j) + fmu * dpsi(j)
			! if positivity not maintained at this value of lamu, get max limit
			if (lamu < 0d0 .and. -lamu / psi(j) > flm) flm = -lamu / psi(j)
		end do
		if (flm > 0d0) then
			! positivity restriction limits amu to safety factor 0.9
			flm = min(flim, 0.9d0 / flm)
		else
			! use overall max limit
			flm = flim
		end if
		! find max of amu
		amu = min(amu, flm)

		return

	end subroutine accelerationAdditional
!******************************************************************************

!******************************************************************************
	subroutine accelerationCheck()

		! set ierr = 4 if past 20 amu values were less than 0.01
		amus(mod(ni,20) + 1) = amu
		if (ni >= 20) then
			if (maxval(amus(1:20)) < 0.01d0) ierr = 4
		end if

		return

	end subroutine accelerationCheck
!******************************************************************************

!******************************************************************************
	subroutine accelerationApplied()

		integer											::	j

		! calculate direction and update psi
		do j = 1, nm
			! update previous delta psi (dpsi0) with direction
			dpsi0(j) = fla * dpsi0(j) + fmu * dpsi(j)
			! update map (psi)
			psi(j) = psi(j) + amu * dpsi0(j)
			! store change on total map
			psic(j,mod(ni,4)+1) = dHdpsi(j) + alf * dSdpsi(j)
		end do

		return

	end subroutine accelerationApplied
!******************************************************************************

!******************************************************************************
	subroutine convergence()

		real(kind(1d0))									::	del0
		integer											::	j

		del = 0d0
		! measure of convergence (Lucy's eq 17)
		do j = 1, nm
			del0 = abs(dHdpsi(j) + alf * dSdpsi(j)) / &
					(abs(dHdpsi(j)) + alf * abs(dSdpsi(j)))
			del = del + del0**2
		end do
		del = sqrt(del / nm)

		return

	end subroutine convergence
!******************************************************************************

!******************************************************************************
	subroutine defaultMap(psi, chi)

		! default map (chi) routine
		real(kind(1d0)), dimension(nm), intent(in)		::	psi
		real(kind(1d0)), dimension(nm), intent(out)		::	chi
		real(kind(1d0)), dimension(np,np)				::	x, y
		integer											::	j

		! initialise x and y
		x = 0d0; y = 0d0
		! unfold psi into x
		do j = 1, nm
			x(indx(j),indy(j)) = psi(j)
		end do
		call gaussianSmear(np, x, y)
		! fold y into chi
		do j = 1, nm
			chi(j) = y(indx(j),indy(j))
		end do

		return

	end subroutine defaultMap
!******************************************************************************

!******************************************************************************
	subroutine gaussianSmear(n, x, y)

		! gaussian smearing with half-width nsw, by consecutive 1-d smearing in
		! x and y
		integer, intent(in)								::	n
		real(kind(1d0)), dimension(n,n), intent(in)		::	x
		real(kind(1d0)), dimension(n,n), intent(out)	::	y
		real(kind(1d0)), dimension(-ms:n+ms)			::	t
		real(kind(1d0))									::	tsum
		integer											::	i, j, k

		! (re)make smearing matrix smp if value of nsw is new
		if (ns0 /= nsw) then
			call smearingMatrix()
		end if
		! smear in j-direction
		t = 0d0
		do i = 1, n
			! extend ith column of x into t
			do j = -ns1, 0
				! fold back
				t(j) = x(i,2-j-1)
			end do
			do j = 1, n
				t(j) = x(i,j)
			end do
			do j = n + 1, n + ns1
				t(j) = x(i,2*n-j+1)
			end do
			! smear t, result into y
			do j = 1, n
				tsum = 0d0
				do k = -ns1, ns1
					tsum = tsum + t(j+k) * smp(k)
				end do
				y(i,j) = tsum
			end do
		end do
		! smear in i-direction
		t = 0d0
		do j = 1, n
			! extend jth row of y into t
			do i = -ns1, 0
				! fold back
				t(i) = y(2-i-1,j)
			end do
			do i = 1, n
				t(i) = y(i,j)
			end do
			do i = n + 1, n + ns1
				t(i) = y(2*n-i+1,j)
			end do
			! smear t, result into y
			do i = 1, n
				tsum = 0d0
				do k = -ns1, ns1
					tsum = tsum + t(i+k) * smp(k)
				end do
				y(i,j) = tsum
			end do
		end do

		return

	end subroutine gaussianSmear
!******************************************************************************

!******************************************************************************
	subroutine smearingMatrix()

		! gaussian smearing matrix smp
		real(kind(1d0))									::	smpsum
		integer											::	i

		smpsum = 0d0
		! actual smearing width used is sw times 1st width nsw
		ns1 = int(sw * nsw)
		if (ns1 > ms) call outputLog(l3, args='"ns1 > ms: "', argi=(/ns1, ms/))
		ns0 = nsw
		do i = -ns1, ns1
			smp(i) = exp(-dble(i*i) / nsw**2)
			smpsum = smpsum + smp(i)
		end do
		! normalise
		do i = -ns1, ns1
			smp(i) = smp(i) / smpsum
		end do

		return

	end subroutine smearingMatrix
!******************************************************************************

!******************************************************************************
	subroutine projectForward(x, y)

		real(kind(1d0)), dimension(nm), intent(in)		::	x
		real(kind(1d0)), dimension(nvm), intent(out)	::	y
		integer											::	i, j, m, n

		y = 0d0
		do i = 1, nvm
			m = ninP(i)
			do j = 1, m
				n = indP(i,j)
				y(i) = y(i) + P(i,j) * x(n)
			end do
		end do

		return

	end subroutine projectForward
!******************************************************************************

!******************************************************************************
	subroutine projectBackward(y, x)

		real(kind(1d0)), dimension(nvm), intent(in)		::	y
		real(kind(1d0)), dimension(nm), intent(out)		::	x
		integer											::	i, j, m, n

		x = 0d0
		do j = 1, nm
			n = ninPt(j)
			do i = 1, n
				m = indPt(j,i)
				x(j) = x(j) + Pt(j,i) * y(m)
			end do
		end do

		return

	end subroutine projectBackward
!******************************************************************************

!******************************************************************************
	real function dist(x)

		real(kind(1d0)), intent(in)						::	x

		if (x < 0d0) then
			dist = 0d0
		else
			if (x < 0.5d0) then
				dist = 2d0 * x**2
			else
				if (x < 1d0) then
					dist = 1d0 - 2d0 * (1d0 - x)**2
				else
					dist = 1d0
				end if
			end if
		end if

		return

	end function dist
!******************************************************************************

!******************************************************************************
	subroutine outputLog(stage, append, pphase, args, argi, argr)

		integer, intent(in)								::	stage
		integer, optional, intent(in)					::	append
		character(*), optional, intent(in)				::	pphase, args
		integer, optional, dimension(2), intent(in)		::	argi
		real(kind(1d0)), optional, dimension(2), intent(in)	::	argr
		integer, dimension(2)							::	pru
		character(len=10)								::	acf
		character(len=40)								::	txt
		integer											::	i, iu, miu
		character(len=255)								::	logfile = ''

		acf = 'sequential'
		if (present(append) .and. append == 1) acf = 'append'
		pru(1) = 6; pru(2) = 10; miu = 2
		logfile = trim(srcpath)//'out/doptomog/doptomog.'//cproj//'.log'
		do i = pri + 1, miu
			iu = pru(i)
			if (i == miu) then
				open(unit = iu, file = trim(logfile), access = trim(acf))
			end if
			select case (stage)
			case (l0)
				! input summary
				if (present(append) .and. present(pphase)) then
					write(iu, '(a1)') ''
					write(iu, '(" - phase range      : ", a2, a)') '', pphase
					write(iu, '(a1)') ''
				else
					write(iu, '(" Fast maximum entropy, floating defaults")')
					if (proj == 0) txt = ' (standard projection)'
					if (proj == 1) txt = ' (inside-out projection)'
					write(iu, '(" proj               : ", i3, a)') proj, txt
					if (ih == 0) txt = ' (log likelihood)'
					if (ih == 1) txt = ' (rms likelihood)'
					write(iu, '(" iH                 : ", i3, a)') iH, txt
					write(iu, '(" nrm                : ", i3)') nrm
					write(iu, '(" nsw                : ", i3)') nsw
					write(iu, '(" nmi                : ", i5)') nmi
					write(iu, '(" acc                : ", es10.2)') acc
					write(iu, '(" alf                : ", es10.2)') alf
					write(iu, '(" amp                : ", es10.2)') amp
					write(iu, '(" wid                : ", es10.2)') wid
				end if
			case (l1)
				! line summary
				if (ni == 1) &
					write(iu, '("  it          Q=H+alfa*S      delta")')
				if (ni /= 1 .and. Q < Q0) then
					write(iu, '(i4, es20.12, es11.2, " **")') ni, Q, del
				else
					write(iu, '(i4, es20.12, es11.2)') ni, Q, del
				end if
			case (l2)
				write(iu, '(a1)') ''
				! iteration summary
				write(iu,'(" ni, alfa, Q:", i5, f8.4, es17.9)') ni, alf, Q
				! convergence summary
				if (ierr == 1) write(iu, '(" not converged")')
				if (ierr == 2) write(iu, '(" not monotonic")')
				if (ierr == 3) write(iu, '(" not converged, not monotonic")')
				if (ierr == 4) write(iu, '(" stuck at vanishing updates")')
				write(iu, '(a1)') ''
				! final summary
				write(iu, '(" entropy", es12.4)') S
				write(iu, '(a1)') ''
			case (l3)
				! errors
				if (present(args)) then
					if (present(argi)) write(iu, '('//args//', 2i5)') argi(1:2)
					if (present(argr)) write(iu, '('//args//', 2es12.4)') argr(1:2)
					if (i == miu) then
						close(iu)
						stop
					end if
				end if
			end select
			if (i == miu) close(iu)
		end do

		return

	end subroutine outputLog
!******************************************************************************

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

!******************************************************************************
end program pdoptomog
!******************************************************************************
