!!!!!!!!!!!!!!!! axion_background !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This module computes the evolution of the background in the presence of an axion field
! We use exact equations up until m=3H, and then treat as a w=0 fluid
! For more details, see Hlozek et al, 2014, arXiv:1410.2896
!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Input cosmological parameters, and receive evolution of equation of state, density,
!adiabatic sound speed
! Also receive initial field value, oscillation scale factor, equality scale factor
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This code The Klein-Gordon equation for a scalar field in an expanding universe (including
!photons, massive and massless neutrinos, cold dark matter, and baryons)
! \ddot{\phi}+2H \phi+m^2 a \phi=0 is transformed using the variable definitions
!where dots denote derivatives with respect to conformal time and H
!is the conformal Hubble parameter and a is the cosmological scale factor
!phi=\sqrt(3/(4\pi G)) v_{1}^{twiddle}
!phi_dot=u_2, u_2=H_{0} u_{2}^twiddle, dimensionless conformal time t^twiddle=H_{0} t
!H_{0} is the usual Hubble parameter, and finally u_{2}^{twiddle}=\sqrt{3/(4\pi G)} v_{2}^{twiddle}
!A dimensionless Hubble parameter littleh is defined as H/(100 km /s/ Mpc)
!as is a dimensionless axion mass maxion_twiddle=m/(H_0), where h
!is the dimensionless Hubble parameter
!This transforms the second order ODE into a pair of first order ODES
!In terms of these variables, there is a nice expression for the adiabatic
! sound speed c_ad^{2}=Pdot/\rho_dot=1+(2/3) maxion_twiddle^{2} v_{1}^{twiddle}a^{2}/(v_{2}^{twiddle}*littleh)

module axion_background

contains

subroutine w_evolve(Params, badflag)
!Params is the overall parameter structure to be passed back to camb, including the estimated a_osc
!value, table for interpolation of the adiabatic sound speed, axion EOS and axion energy density
!flag for failed histories where H becomes negative (axion drives collapse). Flag is raised in derivs routine or
!in w_evolve if a history has a turnaround within 10 log(a) bin steps of the last time step
!Give subroutine access to model parameters from camb, constants from constants.f90, massive neutrino routines

use ModelParams
use constants
use Precision
use MassiveNu
implicit none
type(CAMBparams) :: Params
integer badflag ! flag for failed histories where H becomes negative (axion drives collapse). Flag is raised in derivs routine.
integer i
integer k,j !general indices

!Internal: Neutrino-related constants from CAMB input
!contribution to H^2/(100 km /s/ Mpc)^2 of massive and massless neutrinos, respectively
real(dl) lhsqcont_massive(Params%Nu_mass_eigenstates),lhsqcont_massless
!zeta(3), conversion factor to get neutrino masses in eV for check comparison with rest of CAMB
real(dl) zeta3, conv
!Correction factor from massless to massive neutrino energy densities, constant to go from massive neutrino
!mass fractions to massive neutrino massive values
real(dl)  rhonu,nu_constant
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! non-trivial aspects to sharing neutrino data structures in new subroutines of CAMB
! so we recompute somethings twice, but these are single numbers
! should not be a significant slow down

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Internal:: Cosmological Parameters and useful algebraic combinations
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!omega h^2 of various species
!Matter, Cosmological constant, massive neutrino density
real(dl) omegah2_m, omegah2_lambda,omnuh2
!baryons + cold dark matter, Hubble parameter in units of eV, omega_curvature
real(dl) omegah2_regm,H_ev,rhocrit,omk
!baryons, dark matter separately, axions, axion mass in units of Hubble, dimensionless Hubble Parameter
real(dl) omegah2_b,omegah2_dm,omegah2_ax,maxion_twiddle,hnot
!Dimensionless Hubble^2
real (dl) hsq
!Desired axion fraction omega_a/(omega_a+omega_b+omegac)
real(dl) fax
! scale factor at equality estimated under assumption axions redshift purely as CDM
real(dl) regzeq
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Internal: Evolution control parameters (other than those defined in modules.f90)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!dfac sets m=dfac*H condition required for code to switch from evolving KG+Einstein equations recast in terms of fluid variables
!to evolving WKB equations
!Details in Hlozek et al 2014. arXiv:1410.2896
real(dl) dfac
!how much past aosc to go in the final a integration at the end
real(dl),parameter::eps=0.001
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Internal: Evolution variable arrays
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real(dl) a_arr(ntable) ! scale factor
!scalar field and its derivative (in appropriate units), conformal Hubble parameter /(100 km /s/ Mpc) as a function of scale factor
real(dl) v_vec(2,ntable),littlehfunc(ntable)
!m/(dfac*littlehfunc*a) diagnostic parameter that is used to identify approximate aosc
real(dl) diagnostic(ntable)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Internal: Fluid quantities of interest, computed after evolution generated
!Scalar field energy density
real(dl) grhoax_table_internal(ntable)
!log_e(m/3H) used for array of this quantity to find a_osc, the time of scalar field oscillation
!!arrays used to find aosc once final scalar field initial condition is determined
real(dl) f_arr(1:ntable)
!Array used to find estimate of scale factor at matter-radiation equality (axions counter as matter)
real(dl) eq_arr(ntable)
!!!!!!!!!!!!!!!!!!!!!!!!

! NB some of these quantities a_arr, and grhoax_table_internal are here so that
! we don't have to keep taking logarithms and exponentials of lists
! ultimately we just want the logs of these for cubic spline interpolation in the rest of CAMB
! but to compute Hubble, field derivatives, we need the quantities themselves and not their logs
! By keeping these quantities we can compute them once inside the scalar field routine (per initial condition)
! and keep the information to use for when it is needed
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Internal storage arrays for spline interpolation of scalar field solution
!for fixed scalar initial condition
real(dl) v_buff(1:ntable) ! spline buffer scalar field and its derivative with respect to a
real (dl) abuff(1:ntable) !spline buffer for scale factor interpolation (ie finding 'when
! various quantities like rho_rad/rho_m, m/3H, etc, reach values of interest)
!
real (dl) eq_arr_buff(ntable)
!nstop is a control index that excludes really bad scalar field evolution histories and
!prevents them from screwing up the spline
integer  nstop
!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Quantities of interest that are generated for each scalar field evolution
! and sometimes read into arrays
! energy fraction output (omega_ax/(omega_ax+omega_c+omega_b))
real(dl) fout
!Estimated scalar factor when m=dfac*H, scalar field v(1,i) when this value is reached,
!Estimated scalar field derivative at same point i time
real(dl) aosc,phiosc,phidosc
!log(aosc)
real(dl) laosc
!output value of scalar field value needed to get desired axion density
!obtained via cubic splines, final fout/fax for the corresponding scalar field history
real(dl) vtw,final_fout_check
!critical densities, joining value of rho when axion starts to act like CDM, better log initial value so derivatives can be taken t offset, v2 value at aosc joining point
!used to set full density evolution of final chosen scalar field history
real(dl) drefp
!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Internal storage arrays to sweep through quantities of interest for different
!scalar field evolutions corresponding to different initial conditions
!
! omega_ax/(omega_ax+omega_c+omega_b) for different scalar field initial conditions
real (dl) fout_arr(nphi)
!array of aosc values for different initial conditions
! for the scalar field
real(dl) aosc_arr(nphi)
!log of aosc values for different scalar field histories
real(dl) laosc_arr(nphi)
!array of fout_arr(nphi)/fax (actual axion mass fraction vs desired axion mass fraction)
!logarithm later taken for root finding
real(dl) fout_check_arr(nphi)
! stepsize in log of initial scalar field value
real(dl) dlogvtwiddle_init
!array of initial v1 values
real(dl) vtwiddle_init_arr(nphi)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!WORK NEEDED ON COMMENTS
!!!!!! Simple analytic estimates for required scalar field initial condition
!!! used to set a broad range of scalar initial conditions
!Scalar field evolution is generated for each initial condition and
!cubic spline interpolation is then used to find the one which generates
!desired axion energy fraction today
!initial value max and min for phi_init, and final output
real(dl) vtwiddle_initmax,vtwiddle_initmin,vtwiddle_init
!list of initial values for phi_init
real(dl) vtwiddle_initlist(3)
!!!!!!!!
!WORK NEEDED ON COMMENTS

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Internal storage arrays for spline interpolation of quantities of interest
! for different scalar initial conditions
!array of axion energy fractions, buffer array for spline fitting in space of initial phi values
real (dl) vtwiddle_init_arr_buff(nphi)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Spline derivatives at endpoints (used for all splines)
real(dl) d1,d2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!
!Timing variables
!real :: clock_start, clock_stop
!!!!!!!!!!

!WORK NEEDED ON OMMENTS
! numbers for initial and final value of a, and stepsize
! initial needed to ensure axion sub-dominance to everything else at a_init
real(dl) a_init,a_m, a_lambda, a_rel,as_scalar,as_rad,as_matt,a_final,dloga,log_a_final,log_a_init
real(dl) cmat(1:16,1:16),kvec(1:16,1:2),kfinal(1:2),svec(1:16),avec(1:16)
!END WORK NEEDED ON COMMENTS

!Time Code
!clock_start = 0.0
!call cpu_time(clock_start)
!Set value of neutrino constants as elsewhre in camb
zeta3=1.2020569031595942853997d0
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DM cosmological parameters etc. in units for integrator
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
hnot = Params%H0/100.d0
hsq=hnot**2.0d0
omegah2_dm=Params%omegac*(hnot**2.0d0)
omegah2_b=Params%omegab*(hnot**2.0d0)
omnuh2=Params%omegan*(hnot**2.0d0)

omegah2_lambda=Params%omegav*(hnot**2.0d0)
omegah2_ax=Params%omegaax*(hnot**2.0d0)
maxion_twiddle= Params%ma
!Hubble parameter in eV
H_eV=1.d14*6.5821d-25*hnot/(MPC_in_sec*c)
!convert axion mass units from eV to H
maxion_twiddle = maxion_twiddle/H_eV
!Total densities to juggle and use later
omegah2_regm=omegah2_dm+omegah2_b
omegah2_m=omegah2_regm+omegah2_ax
!Axion Mass Fraction
fax=omegah2_ax/omegah2_m

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Initialize massive and massless neutrino variables
call Nu_init
grhom = 3.0d0*(hsq*1.d10)/(c**2.0d0)
grhog = ((kappa/(c**2.0d0)*4.0d0*sigma_boltz)/(c**3.0d0))*(COBE_CMBTemp**4.0d0)*(Mpc**2.0d0)
grhor = (7.0d0/8.0d0)*((4.0d0/11.0d0)**(4.0d0/3.0d0))*grhog
!calculate critical density
rhocrit=(8.0d0*const_pi*G*1.d3/(3.0d0*((1.d7/(MPC_in_sec*c*1.d2))**(2.0d0))))**(-1.0d0)
Params%omegah2_rad=((COBE_CMBTemp**4.0d0)/(rhocrit))/(c**2.0d0)
Params%omegah2_rad=Params%omegah2_rad*a_rad*1.d1/(1.d4)
!calculate omega rad using starndard formula
!Contribution of photons and massless neutrinos to H/(100 km /s/Mpc)
lhsqcont_massless=(Params%Num_Nu_massless*grhor*(c**2.0d0)/((1.d5**2.0d0)))/3.0d0

Params%omegah2_rad=Params%omegah2_rad+lhsqcont_massless
!print*, 'hi renee', Params%omegah2_rad
!const from modules.f90
nu_constant=(7.0d0/120.0d0)*(const_pi**4.0d0)/(zeta3*1.5d0)
nu_constant=nu_constant*omnuh2*(grhom/grhor)/hsq

do k=1,Params%Nu_mass_eigenstates,1
!Compute neutrino masses corresponding to input mass fractions and degeneracies
	Nu_masses(k)=nu_constant*Params%Nu_mass_fractions(k)/(Params%Nu_mass_degeneracies(k))
!Compute contribution of massive neutrinos to Hubble parameter/100 km/s/Mpc
 	lhsqcont_massive(k)=Params%Nu_mass_degeneracies(k)*(grhor*(c**2.0d0)/((1.d5**2.0d0)))/3.0d0
!Print some useful checks for neutrinos
 !	call Nu_rho(Nu_Masses(k),rhonu)
!	print*,Nu_masses(k),omegah2_rad+lhsqcont_massive(1)*rhonu
 !	conv = k_B*(8.0d0*grhor/grhog/7.0d0)**0.25d0*COBE_CMBTemp/elecV * &
 !   &(Params%Nu_mass_degeneracies(k)/dble(Params%Nu_mass_numbers(k)))**0.25d0!
!	call Nu_rho(1.0d0,rhonu)
!	print*,Nu_masses(k)*conv
enddo
!print*,lhsqcont_massive(1)/Params%Nu_mass_degeneracies(1)

!! Params%omegah2_rad=Params%omegah2_rad+

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Switch between  evolution regimes
!definition of m=nH pmatch point, use 3 for convention
dfac=3.0d0
!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Constants for integrator from
!This is an implementation of the 8th order formulas on page 75 of
!Classical Fifth-, Sixth-, Seventh-, and Eighth-Order Runge-Kutta Formulas with Stepsize Control
!by E Fehlberg
!http://hdl.handle.net/2060/19680027281
!(NASA Huntsville, 1968)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Constant matrix
avec=0.0d0
kvec=0.0d0
avec(1)=0.4436894037649818d0
avec(2)=0.6655341056474727d0
avec(3)=0.9983011584712091d0
avec(4)=0.31550d0
avec(5)=0.5054410094816906d0
avec(6)=0.1714285714285714d0
avec(7)=0.8285714285714285d0
avec(8)=0.6654396612101156d0
avec(9)=0.2487831796806265d0
avec(10)=0.1090d0
avec(11)=0.8910d0
avec(12)=0.3995d0
avec(13)=0.6005d0
avec(14)=1.0d0
avec(15)=0.0d0
avec(16)=1.0d0
cmat=0.0d0
cmat(1,1)=avec(1)
cmat(2,1)=0.1663835264118681d0
cmat(2,2)=0.49915057d0
cmat(3,1)=0.24957528d0
cmat(3,2)=0.0d0
cmat(3,3)=0.74872586d0
cmat(4,1)=0.20661891d0
cmat(4,2)=0.0d0
cmat(4,3)=0.17707880d0
cmat(4,4)=-0.68197715d-1
cmat(5,1)=0.10927823d0
cmat(5,2)=0.0d0
cmat(5,3)=0.0d0
cmat(5,4)=0.40215962d-2
cmat(5,5)=0.39214118d0
cmat(6,1)=0.98899281d-1
cmat(6,2)=0.0d0
cmat(6,3)=0.0d0
cmat(6,4)=0.35138370d-1
cmat(6,5)=0.12476099d0
cmat(6,6)=-0.55745546d-1
cmat(7,1)=-0.36806865d0
cmat(7,2)=0.0d0
cmat(7,3)=0.0d0
cmat(7,4)=0.0d0
cmat(7,5)=-0.22273897d1
cmat(7,6)=0.13742908d1
cmat(7,7)=0.20497390d1
cmat(8,1)=0.45467962d-1
cmat(8,2)=0.0d0
cmat(8,3)=0.0d0
cmat(8,4)=0.0d0
cmat(8,5)=0.0d0
cmat(8,6)=0.32542131d0
cmat(8,7)=0.28476660d0
cmat(8,8)=0.97837801d-2
cmat(9,1)=0.60842071d-1
cmat(9,2)=0.0d0
cmat(9,3)=0.0d0
cmat(9,4)=0.0d0
cmat(9,5)=0.0d0
cmat(9,6)=-0.21184565d-1
cmat(9,7)=0.19596557d0
cmat(9,8)=-0.42742640d-2
cmat(9,9)=0.17434365d-1
cmat(10,1)=0.54059783d-1
cmat(10,2)=0.0d0
cmat(10,3)=0.0d0
cmat(10,4)=0.0d0
cmat(10,5)=0.0d0
cmat(10,6)=0.0d0
cmat(10,7)=.11029325d0
cmat(10,8)=-.12565008d-2
cmat(10,9)=0.36790043d-2
cmat(10,10)=-.57780542d-1
cmat(11,1)=.12732477d0
cmat(11,2)=0.0d0
cmat(11,3)=0.0d0
cmat(11,4)=0.0d0
cmat(11,5)=0.0d0
cmat(11,6)=0.0d0
cmat(11,7)=0.0d0
cmat(11,8)=0.11448805
cmat(11,9)=0.28773020
cmat(11,10)=0.50945379d0
cmat(11,11)=-0.14799682d0
cmat(12,1)=-0.36526793d-2
cmat(12,2)=0.0d0
cmat(12,3)=0.0d0
cmat(12,4)=0.0d0
cmat(12,5)=0.0d0
cmat(12,6)=0.81629896d-1
cmat(12,7)=-0.38607735d0
cmat(12,8)=0.30862242d-1
cmat(12,9)=-0.58077254d-1
cmat(12,10)=0.33598659d0
cmat(12,11)=0.41066880d0
cmat(12,12)=-0.11840245d-1
cmat(13,1)=-0.12375357d1
cmat(13,2)=0.0d0
cmat(13,3)=0.0d0
cmat(13,4)=0.0d0
cmat(13,5)=0.0d0
cmat(13,6)=-0.24430768d2
cmat(13,7)=0.54779568d0
cmat(13,8)=-0.44413863d1
cmat(13,9)=0.10013104d2
cmat(13,10)=-0.14995773d2
cmat(13,11)=0.58946948d1
cmat(13,12)=0.17380377d1
cmat(13,13)=0.27512330d2
cmat(14,1)=-0.35260859d0
cmat(14,2)=0.0d0
cmat(14,3)=0.0d0
cmat(14,4)=0.0d0
cmat(14,5)=0.0d0
cmat(14,6)=-0.18396103d0
cmat(14,7)=-0.65570189d0
cmat(14,8)=-.39086144d0
cmat(14,9)=0.26794646d0
cmat(14,10)=-0.10383022d1
cmat(14,11)=0.16672327d1
cmat(14,12)=0.49551925d0
cmat(14,13)=.11394001d1
cmat(14,14)=0.51336696d-1
cmat(15,1)=0.10464847d-2
cmat(15,2)=0.0d0
cmat(15,3)=0.0d0
cmat(15,4)=0.0d0
cmat(15,5)=0.0d0
cmat(15,6)=0.0d0
cmat(15,7)=0.0d0
cmat(15,8)=0.0d0
cmat(15,9)=-0.67163886d-2
cmat(15,10)=0.81828762d-2
cmat(15,11)=-0.42640342d-2
cmat(15,12)=0.280090294741d-3
cmat(15,13)=-0.87835333d-2
cmat(15,14)=0.10254505d-1
cmat(15,15)=0.0d0
cmat(16,1)=-0.13536550d1
cmat(16,2)=0.0d0
cmat(16,3)=0.0d0
cmat(16,4)=0.0d0
cmat(16,5)=0.0d0
cmat(16,6)=-0.18396103d0
cmat(16,7)=-0.65570189d0
cmat(16,8)=-0.39086144d0
cmat(16,9)=0.27466285d0
cmat(16,10)=-0.10464851d1
cmat(16,11)=0.16714967d1
cmat(16,12)=0.49523916d0
cmat(16,13)=0.11481836d1
cmat(16,14)=0.41082191d-1
cmat(16,15)=0.0d0
cmat(16,16)=1.0d0

svec(1)=0.32256083d-1
svec(2)=0.0d0
svec(3)=0.0d0
svec(4)=0.0d0
svec(5)=0.0d0
svec(6)=0.0d0
svec(7)=0.0d0
svec(8)=0.0d0
svec(9)=0.25983725d0
svec(10)=0.92847805d-1
svec(11)=.16452330d0
svec(12)=0.176659510d0
svec(13)=0.23920102d0
svec(14)=0.39484274d-2
svec(15)=0.3082649547580d-1
!END NEEDS WORK
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! begin initialization procedure, shoot for best phi_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!NEEDS WORK IN COMMNENTS
!Initial aosc guess to tell computer to try to find aosc, also a value that flags when axion doesnt start oscillating by today
aosc=15.0d0
!compute curvature parameter for this set of omegas
omk=1.0d0-(omegah2_m+Params%omegah2_rad+omegah2_lambda+omnuh2)/hsq

!!!!!!!!!
! Determine a range of epochs to be well before in starting axion field evolution
!scale factor at time of axions becoming irrelevant in competition with different species
!and other important transitionary epochs
as_matt=(omegah2_regm/(maxion_twiddle**2.0d0))**(1.0d0/3.0d0)
as_rad=(Params%omegah2_rad/(maxion_twiddle**2.0d0))**(1.0d0/4.0d0)
!scale factor at equality of other matter with radiation
a_m=(Params%omegah2_rad/(omegah2_regm))
!This tims 10^-7 will be another maximum initial scale factor (see below)
a_rel=10.0d0
!Subdominance of dark energy to ordinary radiation
a_lambda=(Params%omegah2_rad/omegah2_lambda)**(0.25d0)
!aosc (start well before coherent oscillation of the axion field)
as_scalar=(omegah2_ax/(maxion_twiddle**2.0d0))**(1.0d0/3.0d0)
!find safe initial a (take analytic estimates for when axions are negligible to everything else
! and look at scalar factors 7 orders of magnitude smaller as initial scale factors!!!
 a_init=min(a_rel,a_lambda,a_m,as_matt,as_rad,as_scalar)*1.d-7
!maximum a
a_final=1.0d0
   !log of various a values, dlog a, step back one
   log_a_init=dlog(a_init)
   log_a_final=dlog(a_final)
  !set log a bin size
   dloga=(log_a_final-log_a_init)/(dble(ntable-1)) ! RH: DG's original
	a_arr(1)=dexp(log_a_init)
!Feed to output parameter table
   !initial loga and a value
   Params%loga_table(1)=log_a_init
   !Generate arrays of log scale factor for output and internal scale factor
   forall(i=2:ntable)
      Params%loga_table(i)=log_a_init+dloga*dble(i-1)
      a_arr(i)=dexp(Params%loga_table(i))
   end forall
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!
!assuming axion acts like cosmological constant then matter,
!analytically obtain
!initial v_1^twiddle value to get right density today,
! under different assumptions
! Expressions will agree with arXiv:1410.2896 in appropriate asymptotic limits
!During Axion domination
vtwiddle_initlist(1)=fax
!Oscillation starts during matter domination
vtwiddle_initlist(2)=fax*omegah2_m/(dsqrt(maxion_twiddle)*((Params%omegah2_rad**0.750d0)))
!Oscillation starts during radiation domination
vtwiddle_initlist(3)=fax*omegah2_m/(dsqrt(maxion_twiddle)*(Params%omegah2_rad))
!Concatenate these initial v_1^twiddle
vtwiddle_initlist=dsqrt(vtwiddle_initlist)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Set range of initial scalar field initial conditions to try
!bracket range of initial vtwiddle 1 values (basically phi 1)
!Spanning many orders of magnitude beyond the simples guesses above to bracket a wide range of initial conditions
!and make sure to choose the correct one
vtwiddle_initmin=min(vtwiddle_initlist(1),vtwiddle_initlist(2),vtwiddle_initlist(3))/1.0d2
vtwiddle_initmax=max(vtwiddle_initlist(1),vtwiddle_initlist(2),vtwiddle_initlist(3))*100.0d1
!set size of log step in v1 initial
dlogvtwiddle_init=(dlog(vtwiddle_initmax)-dlog(vtwiddle_initmin))/(dble(nphi)-1.0d0)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Generate array of initial phi values
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
forall(j=1:nphi)
   vtwiddle_init_arr(j)=dexp(dble(j-1)*dlogvtwiddle_init+dlog(vtwiddle_initmin))
end forall
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!LOOP OVER SCALAR FIELD INITIAL CONDITIONS
do j=1,nphi,1
!Control bad value of aosc -- if a history never gets to m=dfac*H the value of this parameter alerts the code
! that this is a history for which coherent oscillation never begins

   aosc=15.0d0
!!!!initial phi value
   vtwiddle_init=vtwiddle_init_arr(j)

   !start axion at rest at top of hill, with phi guessed at current guess
   v_vec(1,1)=vtwiddle_init
   v_vec(2,1)=0.0d0
   !calculate dimensionless hubble including standardmatter and axion potential and kinetic energy
   call lh(omegah2_regm,Params%omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,a_arr(1),v_vec(1:2,1),littlehfunc(1),badflag,&
        lhsqcont_massless,lhsqcont_massive,Params%Nu_mass_eigenstates,Nu_masses)

   !calculate initial value of dphi/da and dphidot/da
    !Compute first step parameters for the pair of first-order ODEs being solved
   kvec=0.0d0
   kfinal=0.0d0
   call next_step(a_arr(1),v_vec(1:2,1),kvec(1:16,1:2),kfinal(1:2),avec(1:16),&
   	&omegah2_regm,Params%omegah2_rad,&
    &omegah2_lambda,omk,hsq,&
	&maxion_twiddle,badflag,dloga,16,cmat(1:16,1:16),lhsqcont_massless,lhsqcont_massive,&
	&Params%Nu_mass_eigenstates,Nu_masses)

   diagnostic(1)=dfac*littlehfunc(1)/a_arr(1)

!!!!

!!!!!!!!!!!!!!!!!!!!!!
!Integration performed using eight order Runge-Kutta method
!Derivatives at 8 points in advance of the one in question (with trial function values)
!Added to current value using optimal quadrature coefficients under certain assumptions
!This is an implementation of the 8th order formulas on page 75 of
!Classical Fifth-, Sixth-, Seventh-, and Eighth-Order Runge-Kutta Formulas with Stepsize Control
!by E Fehlberg
!http://hdl.handle.net/2060/19680027281
!(NASA Huntsville, 1968)
!It turns out a reasonably accurate integrator is required to accurately obtain the adiabatic sound speed at earlier times
!Using super-horizon analytic solutions, we found that this integrator + 5000 grid points
!was necessary to avoid exciting a non-physically large low-l ISW effect
! DM please add comments on which condition led us to this realiztion???

   do i=2,ntable,1
!!!!integrate ODE using 16 pt (8th order Runge-Kutta) rule
      !increment fluid (homogeneous values) using precomputed steps
      v_vec(:,i)=v_vec(:,i-1)+(svec(1)*kvec(1,:)+svec(9)*kvec(9,:)+svec(10)*kvec(10,:)&
           &+svec(11)*kvec(11,:)+svec(12)*kvec(12,:)+svec(13)*kvec(13,:)&
           &+svec(14)*kvec(14,:)+svec(15)*kvec(15,:))
!!!!
      !calculate hubble for next step
      call lh(omegah2_regm,Params%omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,a_arr(i),v_vec(1:2,i),littlehfunc(i),badflag,&
           &lhsqcont_massless,lhsqcont_massive,Params%Nu_mass_eigenstates,Nu_masses)

      kvec=0.0d0
      kfinal=0.0d0

      !Compute next steps in scalar field and its derivative
      call next_step(a_arr(i),v_vec(1:2,i),kvec(1:16,1:2),kfinal(1:2),&
      &avec(1:16),omegah2_regm,Params%omegah2_rad,omegah2_lambda,omk,hsq,&
           &maxion_twiddle,badflag,dloga,16,cmat(1:16,1:16),&
           &lhsqcont_massless,lhsqcont_massive,Params%Nu_mass_eigenstates,Nu_masses)

      !compare m to nH and identify a reasonable guess for when a given history crosses the m=3H
      ! condition (and thus when the code will switch from pure scalar evolution to coherent oscillation)
      diagnostic(i)=dfac*littlehfunc(i)/a_arr(i)
      ! find first guess for aosc
      if (i .gt. 1) then
         if (aosc .eq. 15.0d0) then
            if (maxion_twiddle .lt.diagnostic(i-1)) then
            if (maxion_twiddle .ge.diagnostic(i)) then
               aosc=a_arr(i)
            endif
         endif
      endif
   endif
enddo
!!!!now there's an array of dlog(diagnostic), use a simple spline to find aosc

f_arr(1:ntable)=maxion_twiddle/(diagnostic(1:ntable))
f_arr=dlog(f_arr)

if (aosc .ne. 15.0d0) then

d1=(Params%loga_table(2)-Params%loga_table(1))/(f_arr(2)-f_arr(1))
d2=(Params%loga_table(ntable)-Params%loga_table(ntable-1))/(f_arr(ntable)-f_arr(ntable-1))

call spline(f_arr(1:ntable),(Params%loga_table(1:ntable)),ntable,d1,d2,abuff(1:ntable))
call spline_out(f_arr(1:ntable),Params%loga_table(1:ntable),&
	&abuff(1:ntable)&
	&,ntable,0.0d0,laosc)

!use a simple spline to calculate phi at time oscillation begins (important to get relic density later, which will be off by a factor of order unity depending on how aosc is defined)
!Finds root of equation log(m/3H)=0 uisng a cubic spline
d1=(v_vec(1,2)-v_vec(1,1))/(Params%loga_table(2)-Params%loga_table(1))
d2=(v_vec(1,ntable)-v_vec(1,ntable-1))/(Params%loga_table(ntable)-Params%loga_table(ntable-1))
do i=1,ntable-10,1
!!       print*,i,isnan(f_arr(i))
!
do k=0,10,1
call lh(omegah2_regm,Params%omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,a_arr(i+k),v_vec(1:2,i+k),littlehfunc(i+k),badflag,&
	&lhsqcont_massless,lhsqcont_massive,Params%Nu_mass_eigenstates,Nu_masses)
        if (((isnan(f_arr(i+k))).or.(isnan(v_vec(1,i+k))) ).or.(isnan(v_vec(2,i+k))))then
                print*,i,k,littlehfunc(i+k),v_vec(1,i+k),v_vec(2,i+k),a_arr(i+k),dexp(laosc)
        endif
enddo
enddo

!Find scalar field value at moment of m=nH (fiducial onset of coherent oscillation)
call spline(Params%loga_table(1:ntable),v_vec(1,1:ntable),ntable,d1,d2,&
      v_buff(1:ntable))
call spline_out(Params%loga_table(1:ntable),v_vec(1,1:ntable),&
	&v_buff(1:ntable)&
	&,ntable,laosc,phiosc)

!Find scalar field derivative with scale factor at moment of m=nH (fiducal onset of coherent
!oscillation)
!use a cubic spline to calculate phidot at time rolling begins, we can see perfect equipartition between kinetic and potential scalar field energy is not yet achieved at m=3H, but this is good enough for government work
d1=(v_vec(2,2)-v_vec(2,1))/(Params%loga_table(2)-Params%loga_table(1))
d2=(v_vec(2,ntable)-v_vec(2,ntable-1))/(Params%loga_table(ntable)-Params%loga_table(ntable-1))
call spline(Params%loga_table(1:ntable),v_vec(2,1:ntable),ntable,d1,d2,v_buff(1:ntable))
call spline_out(Params%loga_table(1:ntable),v_vec(2,1:ntable),&
     &v_buff(1:ntable)&
     &,ntable,laosc,phidosc)

aosc=dexp(laosc)
!calculate axion energy density fraction (compared to total matter+axion)
!parcel these numbers of interest into an array which sweeps through different v1 values
!Beyond a>aosc, a simple a^-3 energy density scaling is applied
fout=((maxion_twiddle*phiosc)**2.0d0+(phidosc/aosc)**2.0d0)*(aosc**3.0d0)
fout=fout/(omegah2_regm+((maxion_twiddle*phiosc)**2.0d0+(phidosc/aosc)**2.0d0)*(aosc**3.0d0))
!print*,vtwiddle_init,aosc,fout,fax
fout_arr(j)=fout
fout_check_arr(j)=fout/fax
aosc_arr(j)=(aosc)
f_arr=dexp(f_arr)
else
!(case of no oscillation, just use result from full scalar field evolution)
f_arr=dexp(f_arr)
fout=(v_vec(2,ntable)/a_arr(ntable))**2.0d0+(maxion_twiddle*v_vec(1,ntable))**2.0d0
fout=fout/(fout+omegah2_regm)
fout_arr(j)=fout
fout_check_arr(j)=fout/fax
aosc_arr(j)=aosc
endif

enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! End of sweep through different evolutions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!DM
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Spline results of shooting method
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

vtwiddle_init_arr=dlog(vtwiddle_init_arr)
fout_check_arr=dlog(fout_check_arr)
fout_arr=dlog(fout_arr)

!Exclude histories that crashed
nstop=0
do j=1,nphi,1
   if (j .lt. nphi) then
      if ((dexp(fout_check_arr(j+1)).eq.dexp(fout_check_arr(j)))) then
         if (nstop.eq.0) then
            nstop=j
         endif
      endif
   endif
!   print*,j,fout_check_arr(j)
enddo
if (nstop .eq. 0) then
   nstop=nphi
endif
!
!!!cubic spline to find best initial phi value to get axion energy fraction that is desire
d1=(vtwiddle_init_arr(2)-vtwiddle_init_arr(1))/(fout_check_arr(2)-fout_check_arr(1))
d2=(vtwiddle_init_arr(nstop)-vtwiddle_init_arr(nstop-1))
d2=d2/(fout_check_arr(nstop)-fout_check_arr(nstop-1))
call spline(fout_check_arr(1:nstop),vtwiddle_init_arr(1:nstop),nstop,d1,d2,vtwiddle_init_arr_buff(1:nstop))
call spline_out(fout_check_arr(1:nstop),vtwiddle_init_arr(1:nstop),&
	&vtwiddle_init_arr_buff(1:nstop)&
	&,nstop,0.0d0,vtw)

!!!use a cubic spline to check that correct axion energy fraction is indeed achieved here
d1=(vtwiddle_init_arr(2)-vtwiddle_init_arr(1))/(fout_arr(2)-fout_arr(1))
d1=1.d0/d1
d2=(vtwiddle_init_arr(nstop)-vtwiddle_init_arr(nstop-1))
d2=d2/(fout_arr(nstop)-fout_arr(nstop-1))
d2=1.0d0/d2
!!!
call spline(vtwiddle_init_arr(1:nstop),fout_arr(1:nstop),nstop,d1,d2,vtwiddle_init_arr_buff(1:nstop))
call spline_out(vtwiddle_init_arr(1:nstop),fout_arr(1:nstop),&
     &vtwiddle_init_arr_buff(1:nstop)&
     &,nstop,vtw,final_fout_check)
!print*,dexp(final_fout_check)*omegah2_regm/(1.0d0-dexp(final_fout_check)),fax*omegah2_regm/(1.0d0-(fax))

!Use cubic spline to get aosc for this best (and chosen history)
laosc_arr=dlog(aosc_arr)
d1=(vtwiddle_init_arr(2)-vtwiddle_init_arr(1))/(aosc_arr(2)-aosc_arr(1))
d1=1.d0/d1
d2=(vtwiddle_init_arr(nstop)-vtwiddle_init_arr(nstop-1))
d2=d2/(laosc_arr(nstop)-laosc_arr(nstop-1))
d2=1.0d0/d2
call spline(vtwiddle_init_arr(1:nstop),laosc_arr(1:nstop),nstop,d1,d2,vtwiddle_init_arr_buff(1:nstop))
call spline_out(vtwiddle_init_arr(1:nstop),laosc_arr(1:nstop),&
     &vtwiddle_init_arr_buff(1:nstop)&
     &,nstop,vtw,Params%a_osc)
vtw=dexp(vtw)
Params%a_osc=dexp(Params%a_osc)
if (Params%a_osc .ge. 1.0d0) then
   Params%a_osc=1.0d0
endif

!!!!!!!!!!!!!!!!!!!!!!!!!
! DM log a integration at best fit initial field value for output
!!!!!!!!!!!!!!!!!!!!!!!!

!Do same log scale factor integration at bestfit phi value to get history of fluid variables
!!Set scale factor integration range
a_init=dexp(log_a_init)
if (Params%a_osc .le. 1.0d0) then
a_final=Params%a_osc*(1.0d0+eps)
else
a_final=1.0d0
endif
log_a_final=dlog(a_final)
dloga=(log_a_final-log_a_init)/dble(ntable-1)

!Set intial value
vtwiddle_init=vtw

!initial loga and a value
Params%loga_table(i)=log_a_init
a_arr(1)=dexp(Params%loga_table(i))
!start axion at rest at top of hill, with phi guessed at current guess
v_vec(1,1)=vtwiddle_init
v_vec(2,1)=0.0d0

!Compute initial Hubble
call lh(omegah2_regm,Params%omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,a_arr(1),v_vec(1:2,1),littlehfunc(1),badflag,&
	&lhsqcont_massless,lhsqcont_massive,Params%Nu_mass_eigenstates,Nu_masses)

!Compute first step parameters
kvec=0.0d0
kfinal=0.0d0
call next_step(a_arr(1),v_vec(1:2,1),kvec(1:16,1:2),kfinal(1:2),avec(1:16),omegah2_regm,Params%omegah2_rad,omegah2_lambda,omk,hsq,&
	&maxion_twiddle,badflag,dloga,16,cmat(1:16,1:16),lhsqcont_massless,lhsqcont_massive,Params%Nu_mass_eigenstates,Nu_masses)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DM: do loop for pulling out values at correct initial phi
!time integration, pull out same values at each time step
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

badflag=0

forall(i=2:ntable)
   Params%loga_table(i)=log_a_init+dloga*dble(i-1)
   a_arr(i)=dexp(Params%loga_table(i))
end forall

do i=2,ntable,1
   !Take step using previously computed step parameters
   v_vec(1:2,i)=v_vec(1:2,i-1)+(svec(1)*kvec(1,1:2)+svec(9)*kvec(9,1:2)+svec(10)*kvec(10,1:2)&
	&+svec(11)*kvec(11,1:2)+svec(12)*kvec(12,1:2)+svec(13)*kvec(13,1:2)&
	&+svec(14)*kvec(14,1:2)+svec(15)*kvec(15,1:2))

	!Compute Hubble/(km/s/Mpc)
   call lh(omegah2_regm,Params%omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,a_arr(i),v_vec(1:2,i),littlehfunc(i),badflag,&
	&lhsqcont_massless,lhsqcont_massive,Params%Nu_mass_eigenstates,Nu_masses)

kvec=0.0d0
kfinal=0.0d0
!compute next step parameters

call next_step(a_arr(i),v_vec(1:2,i),kvec(1:16,1:2),kfinal(1:2),avec(1:16),omegah2_regm,&
	&Params%omegah2_rad,omegah2_lambda,omk,hsq,&
	&maxion_twiddle,badflag,dloga,16,cmat(1:16,1:16),&
	&lhsqcont_massless,lhsqcont_massive,Params%Nu_mass_eigenstates,Nu_masses)
enddo

!Compute m/3H as a function of scale factor, as well as the scalar field equation of state
!and appropriately normalized energy density
forall(i=1:ntable)
diagnostic(i)=dfac*littlehfunc(i)/a_arr(i)
Params%wax_table(i)=(((v_vec(2,i)/(a_arr(i)))**2.0d0)-((v_vec(1,i)*maxion_twiddle)**2.0d0))
Params%wax_table(i)=Params%wax_table(i)/(((v_vec(2,i)/(a_arr(i)))**2.0d0)+((v_vec(1,i)*maxion_twiddle)**2.0d0))
!!tabulate axion energy density
grhoax_table_internal(i)=((v_vec(2,i)/a_arr(i))**2.0d0+(maxion_twiddle*v_vec(1,i))**2.0d0)
end forall
!This is the axion energy density *h^2/(3H_0^2/8\pi G), where h is the dimensionless Hubble Parameter
!so in camb's definitions grhoa2_axion=grhom*grhox_table_internal(i)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Spline final arrays
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!with complete history in hand, spline to find axion energy density at a=aosc
Params%a_osc=dlog(Params%a_osc)
Params%grhoax_table=dlog(grhoax_table_internal)
   d1=(Params%grhoax_table(2)-Params%grhoax_table(1))/(Params%loga_table(2)-Params%loga_table(1))
d2=(Params%grhoax_table(ntable)-Params%grhoax_table(ntable-1))/(Params%loga_table(ntable)-Params%loga_table(ntable-1))
call spline(Params%loga_table(1:ntable),Params%grhoax_table(1:ntable),ntable,d1,d2,Params%grhoax_table_buff)
call spline_out(Params%loga_table(1:ntable),Params%grhoax_table(1:ntable),&
	&Params%grhoax_table_buff(1:ntable)&
	&,ntable,Params%a_osc,drefp)

Params%a_osc=dexp(Params%a_osc)
drefp=dexp(drefp)

!Replace putative scalar field solution with a^-3 solution at match point
!for CAMB+CosmoMC (or Cosmosis) adequate time griddings, scalar field EOMs cannot be solved exactly
!Thus we switch to this scaling
do i=1,ntable,1
if (a_arr(i) .gt. Params%a_osc) then
grhoax_table_internal(i)=drefp*((Params%a_osc/a_arr(i))**3.0d0)
endif
enddo
Params%grhoax_table=dlog(grhoax_table_internal)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!calculate axion adiabatic sound speed Pdot/rhodot, asymptoting to constant (physical) value at low a, when small machine numbers start to behave badly
!!Apply analytic expression for Pdot/rdhot so that
!!noisy numerical derivatives need no be used
forall(i=1:ntable)
Params%cs2_table(i)=1.0d0+2.0d0*((maxion_twiddle*a_arr(i))**2.0d0)*v_vec(1,i)/(3.0d0*v_vec(2,i)*littlehfunc(i))
end forall
Params%cs2_table(1)=Params%cs2_table(2)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!Use WKB averages of cs2_adiabatic and w_axion after a>a_osc
do i=1,ntable,1
if (a_arr(i) .gt. Params%a_osc) then
Params%cs2_table(i)=0.0d0
Params%wax_table(i)=0.0d0
endif
enddo
!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!
!use same spline method used in rest of subroutine to find new aeq value in this cosmological history (will be needed in initial condition code to normalize, time, scale factor, etc, in particular for isocurvature mode
forall(i=1:ntable)
eq_arr(i)=((omegah2_regm/(a_arr(i)**3.0d0)+grhoax_table_internal(i))/(Params%omegah2_rad/(a_arr(i)**4.0d0)))
end forall
eq_arr=dlog(eq_arr)
d1=(Params%loga_table(2)-Params%loga_table(1))/(eq_arr(2)-eq_arr(1))
d2=(Params%loga_table(ntable)-Params%loga_table(ntable-1))/(eq_arr(ntable)-eq_arr(ntable-1))
call spline(eq_arr(1:ntable),(Params%loga_table(1:ntable)),ntable,d1,d2,eq_arr_buff(1:ntable))
call spline_out(eq_arr(1:ntable),Params%loga_table(1:ntable),&
     &eq_arr_buff(1:ntable)&
     &,ntable,0.0d0,Params%aeq)
     Params%aeq=dexp(Params%aeq)
!Sometimes this spline breaks if a_osc<a_eq, in that case simpler expressions can be used
	regzeq=(Params%omegah2_rad+sum(lhsqcont_massive))/(omegah2_b+omegah2_dm+omegah2_ax)
	if (Params%a_osc.lt.regzeq) then
		Params%aeq=regzeq
	endif
!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!put axion energy density in units used in camb time integrations
forall(i=1:ntable)
	Params%grhoax_table(i)=Params%grhoax_table(i)-dlog(hsq)
end forall
Params%drefp_hsq=drefp/hsq
Params%grhoax_table=dlog10(dexp(Params%grhoax_table))

! Now moved to equations_ppf.f90
!!! For the fisher code for later:
!open(unit=983, file="/Users/reneehlozek/Code/OxFishDec15_axion/results/cambOutput/grhoax.dat", action="write", status="replace")
!do i=1,ntable
!   write(983,*) dexp(Params%loga_table(i)), Params%grhoax_table(i)
!end do

!close(983)
!!! RH
Params%loga_table=dlog10(dexp(Params%loga_table))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!create spline buffer arrays for all quatntities of interest as a function of time in code, this will allow camb to calculate via interpolation any of the quantities of interest at any time
!EOS of axions
d1=(Params%wax_table(2)-Params%wax_table(1))/(Params%loga_table(2)-Params%loga_table(1))
d2=(Params%wax_table(ntable)-Params%wax_table(ntable-1))/(Params%loga_table(ntable)-Params%loga_table(ntable-1))
call spline(Params%loga_table(1:ntable),Params%wax_table(1:ntable),ntable,d1,d2,Params%wax_table_buff(1:ntable))
!adiabatic sound speed of axions=Pdot/rhodot
d1=(Params%cs2_table(3)-Params%cs2_table(2))/(Params%loga_table(3)-Params%loga_table(2))
d2=(Params%cs2_table(ntable)-Params%cs2_table(ntable-1))/(Params%loga_table(ntable)-Params%loga_table(ntable-1))
call spline(Params%loga_table(2:ntable),(Params%cs2_table(2:ntable)),ntable-1,d1,d2,Params%cs2_table_buff(2:ntable))
!SPINE SCALAR FIELD ENERGY DENSITY FOR LATER USE IN CAMB
d1=(Params%grhoax_table(2)-Params%grhoax_table(1))/(Params%loga_table(2)-Params%loga_table(1))
d2=(Params%grhoax_table(ntable)-Params%grhoax_table(ntable-1))/(Params%loga_table(ntable)-Params%loga_table(ntable-1))
call spline(Params%loga_table(1:ntable),Params%grhoax_table(1:ntable),ntable,d1,d2,Params%grhoax_table_buff(1:ntable))
!!!!!!!!!!!!!!!!!!!!!!!

!!feed out real (dl) valued version of all this stuff for output
!put scalar field initial condition in planck units
Params%phiinit=vtw*sqrt(6.0d0)
if (Params%use_axfrac) then
   Params%axfrac = Params%axfrac
else
   Params%axfrac = fax
end if

if (Params%axion_isocurvature) then

Params%amp_i = Params%Hinf**2/(pi**2*Params%phiinit**2)
Params%r_val  = 2*(Params%Hinf**2/(pi**2.*Params%InitPower%ScalarPowerAmp(1)))
Params%alpha_ax = Params%amp_i/Params%InitPower%ScalarPowerAmp(1)
!print*, 'computing isocurvature', Params%amp_i, Params%r_val, Params%axfrac**2*Params%amp_i/Params%InitPower%ScalarPowerAmp(1), Params%Hinf
!print*, 'computing isocurvature, Params%amp_i, Params%r_val, Params%axfrac**2*Params%amp_i/Params%InitPower%ScalarPowerAmp(1), Params%Hinf'
end if

!output omega_r
Params%omegar=Params%omegah2_rad/hsq

!!!!Timing Stuff
!clock_stop = 0.0
!call cpu_time(clock_stop)
!print*,'axion bg subroutine timing:', clock_stop - clock_start
end subroutine w_evolve

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

!!!!!!!!!!!!!!!!!!!!!!!!
! Begin derivative routine
!!!!!!!!!!!!!!!!!!!!!!!!

subroutine derivs(a,v,dvt_dloga,omegah2_regm,omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,badflag,&
	&lhsqcont_massless,lhsqcont_massive,Nu_mass_eigenstates,Nu_masses)
use constants
use Precision
implicit none
integer badflag,Nu_mass_eigenstates
real(dl) a
real(dl) dvt_dloga(1:2),dvt_da(1:2),lhr
real(dl) v(1:2)
real(dl) omegah2_regm,omegah2_rad,omegah2_lambda
real(dl) maxion_twiddle,Nu_masses(Nu_mass_eigenstates)
real(dl) omk,hsq,lhsqcont_massless,lhsqcont_massive(Nu_mass_eigenstates)

!Compute hubble dimensionless
call lh(omegah2_regm,omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,a,v,lhr,badflag,&
	&lhsqcont_massless,lhsqcont_massive,Nu_mass_eigenstates,Nu_masses)

!calculate fluid derivatives (d/dloga )for next step
!Solving Equation described and defined in top part of this fortran file
dvt_da(1)=v(2)/(a*(lhr))
dvt_da(2)=-2.0d0*v(2)/(a)-(maxion_twiddle**2.0d0)*a&
      *v(1)/(lhr)
dvt_dloga(1:2)=a*dvt_da(1:2)
end subroutine derivs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Compute H/(100 km/s/Mpc) at any moment in our cosmological history
subroutine lh(omegah2_regm,omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,a,v,littlehfunc,&
	&badflag,&
	&lhsqcont_massless,lhsqcont_massive,Nu_mass_eigenstates,nu_masses)
use constants
use Precision
use MassiveNu
implicit none
integer badflag,Nu_mass_eigenstates,i
real(dl) omegah2_regm,omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,a
real(dl) v(1:2),littlehfunc,lhsqcont_massless,lhsqcont_massive(Nu_mass_eigenstates)
real(dl) mass_correctors(Nu_mass_eigenstates),rhonu
real(dl) nu_masses(Nu_mass_eigenstates)

!Compute corrections to neutrino energy density from massless to massive case
do i=1,Nu_mass_eigenstates,1
call Nu_rho(a*nu_masses(i),rhonu)
mass_correctors(i)=rhonu
enddo
!!!!!!!

!Compute H/(100 km /s/Mpc), contributions from normal stuff
littlehfunc=(omegah2_regm/(a**3.0d0)+omegah2_rad/(a**4.0d0))+&
	&sum(lhsqcont_massive*mass_correctors,Nu_mass_eigenstates)/(a**4.0d0)

!Contributions from cosmological constant and scalar field
littlehfunc=littlehfunc+omegah2_lambda+((v(2)/a)**2.0d0)
littlehfunc=littlehfunc+(maxion_twiddle*v(1))**2.0d0
littlehfunc=littlehfunc*(a**2.0d0)+omk*hsq
! DM flag histories where h goes negative, i.e. do not want collapsing universe
if (littlehfunc .le. 0.0d0) then
        badflag=1
endif
if (isnan(littlehfunc)) then
badflag = 1
endif
!

littlehfunc=dsqrt(littlehfunc)

end subroutine

!!!!! Take next step in integration using method described above

subroutine next_step(a,v,kvec,kfinal,avec,omegah2_regm,omegah2_rad,omegah2_lambda,omk,&
	&hsq,maxion_twiddle,badflag,dloga,nstep,cmat,&
	&lhsqcont_massless,lhsqcont_massive,Nu_mass_eigenstates,Nu_masses)
use constants
use Precision
implicit none

real(dl) hsq,a,v(1:2),kvec(1:nstep,1:2),omegah2_regm,omegah2_rad,omegah2_lambda,maxion_twiddle,dloga,omk
real(dl) vfeed(1:2),cmat(1:nstep,1:nstep),kfinal(1:2),avec(1:nstep)
integer Nu_mass_eigenstates
integer nstep,cp,m,badflag
real(dl) lhsqcont_massless,lhsqcont_massive(Nu_mass_eigenstates)
real(dl) Nu_masses(Nu_mass_eigenstates)

	kvec=0.0d0
kfinal=0.0d0
			call derivs(a,v(1:2),kvec(1,1:2),omegah2_regm,omegah2_rad,omegah2_lambda,omk,hsq,maxion_twiddle,badflag,&
	&lhsqcont_massless,lhsqcont_massive,Nu_mass_eigenstates,Nu_masses)
			kvec(1,1:2)=kvec(1,1:2)*dloga
			do m=1,nstep,1
			do cp=1,2,1
	vfeed(cp)=dot_product(cmat(m,1:m),kvec(1:m,cp))

	enddo
     if (m .le. (nstep-1)) then
	call derivs(a*dexp(dloga*avec(m)),v(1:2)+vfeed(1:2),&
	&kvec(m+1,1:2),omegah2_regm,omegah2_rad,omegah2_lambda,omk,hsq&
     &,maxion_twiddle,badflag,lhsqcont_massless,lhsqcont_massive,Nu_mass_eigenstates,Nu_masses)
kvec(m+1,1:2)=kvec(m+1,1:2)*dloga
else
call derivs(a*dexp(dloga*avec(m)),v(1:2)+vfeed(1:2),&
	&kfinal(1:2),omegah2_regm,omegah2_rad,omegah2_lambda,omk,hsq&
	&,maxion_twiddle,badflag,lhsqcont_massless,lhsqcont_massive,Nu_mass_eigenstates,Nu_masses)
	kfinal(1:2)=kfinal(1:2)*dloga
endif
enddo
end subroutine

!!!!!!!!

end module axion_background


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of dj in forward (tangent) mode:
!   variations   of useful results: dj
!   with respect to varying inputs: *temp *propunit *tsal *pres
!   Plus diff mem management of: temp:in propunit:in tsal:in pres:in
!>    @brief average effective diffusivities on cell faces in y direction
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] spec species
!>    @param[in] ismpl local sample index
!>    @return effective diffusivities (J/mK)
DOUBLE PRECISION FUNCTION g_DJ(i, j, k, spec, ismpl, dj)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_GENRL
  IMPLICIT NONE
  INTEGER :: ismpl
  INTEGER :: i, j, k
  INTEGER :: spec
  DOUBLE PRECISION :: f1, f2, prod, summ, betx, bety, betz, bet
  DOUBLE PRECISION :: g_f1, g_f2, g_prod, g_summ, g_betx, &
& g_bety, g_betz, g_bet
  EXTERNAL POR, DISP, VY, VX, VZ
  EXTERNAL g_POR, g_DISP, g_VY, g_VX, g_VZ
  DOUBLE PRECISION :: POR, DISP, VY, VX, &
& VZ
  DOUBLE PRECISION :: g_POR, g_DISP, g_VY, g_VX, g_VZ
  INTRINSIC SQRT
  DOUBLE PRECISION :: result1
  DOUBLE PRECISION :: g_result1
  DOUBLE PRECISION :: result2
  DOUBLE PRECISION :: g_result2
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: dj
  dj = 0.d0
  betx = 0.d0
  bety = 0.d0
  betz = 0.d0
  IF (k0 .GT. 1 .AND. k .LT. k0) THEN
    g_betz = g_VZ(i, j, k, ismpl, betz)
    g_betz = 2*betz*g_betz
    betz = betz*betz
  ELSE
    g_betz = 0.D0
  END IF
  IF (i0 .GT. 1 .AND. i .LT. i0) THEN
    g_betx = g_VX(i, j, k, ismpl, betx)
    g_betx = 2*betx*g_betx
    betx = betx*betx
  ELSE
    g_betx = 0.D0
  END IF
  IF (j0 .GT. 1 .AND. j .LT. j0) THEN
    g_bety = g_VY(i, j, k, ismpl, bety)
    g_bety = 2*bety*g_bety
    bety = bety*bety
    temp0 = SQRT(betx + bety + betz)
    IF (betx + bety + betz .EQ. 0.0) THEN
      g_bet = 0.D0
    ELSE
      g_bet = (g_betx+g_bety+g_betz)/(2.0*temp0)
    END IF
    bet = temp0
    g_result1 = g_POR(i, j, k, ismpl, result1)
    g_result2 = g_DISP(i, j, k, ismpl, result2)
    g_f1 = diff_c(spec)*g_result1 + bet*g_result2 + result2*&
&     g_bet
    f1 = result1*diff_c(spec) + result2*bet
    g_result1 = g_POR(i, j + 1, k, ismpl, result1)
    g_result2 = g_DISP(i, j + 1, k, ismpl, result2)
    g_f2 = diff_c(spec)*g_result1 + bet*g_result2 + result2*&
&     g_bet
    f2 = result1*diff_c(spec) + result2*bet
    g_prod = f2*g_f1 + f1*g_f2
    prod = f1*f2
    g_summ = dely(j+1)*g_f1 + dely(j)*g_f2
    summ = f1*dely(j+1) + f2*dely(j)
    IF (summ .GT. 0.d0) THEN
      g_dj = 2.d0*(g_prod-prod*g_summ/summ)/summ
      dj = 2.d0*prod/summ
    ELSE
      g_dj = 0.D0
    END IF
  ELSE
    g_dj = 0.D0
  END IF
  RETURN
END FUNCTION g_DJ


C    %W% %G%
        subroutine getfex (fex, efd, ve, ifld, kc)
        real fex, efd, ve, ifld, kc
C
C       This subroutine calculates the initial VE using initial
C       values EFD, IFLD, and KC.
C
        include 'tspinc/prt.inc'
        include 'tspinc/int3.inc'

        real in

        l6 = 6
C
C       If KC is zero, the derivation is trival
C
        if (kc .eq. 0.0) then
           ve = amax1(efd,0.0)
           fex = 1.0
           efdx = fex*ve
           return
        endif
C
C       Find initial balance (start with IN in midpoint range)
C
        in = 0.5*(0.51 + 0.715)
        ve = abs(kc*ifld/in)
C
C       Begin iteration
C
        do itr = 1,10
          if (ve .gt. 0.0) then
            in = kc*ifld/ve
          else
            in = 0.0
          endif
C
C         Determine range of operation
C
          if (abs(in) .le. 0.51) then
            c1 = 0.0
            c2 = -0.58*kc
            c3 = 1.0
            fex = 1.0 - 0.58*abs(in)
          else if (abs(in) .lt. 0.715) then
             c1 = -0.865*kc**2
             c2 = -0.01429*kc
             c3 = 0.93227
             fex = -0.865*(abs(in) + 0.00826)**2 + 0.93233
          else if (abs(in) .lt. 0.9802) then
             c1 = 0.0
             c2 = -1.714*kc
             c3 = 1.68
             fex = 1.68 - 1.714*abs(in)
          else
             c1 = 0.0
             c2 = 0.0
             c3 = 0.0
             fex = 0.0
             ve = amax1 (efd,0.0)
C
C            ERROR - ILLEGAL OPERATING RANGE
C
             write (errbuf(1),30) name,base,id,in,kc,ifld,ve
   30        format('0 ILLEGAL EXCITER OPERATING RANGE ',a8,2x,f5.1,2x,
     &          a1, ' IN ',f9.6,' KC ',f9.6,' IFLD ',f9.6,' VE ',f9.6)
             call prterr('E',1)
             imchn = 3
             return
          endif
          efdx = ve*fex
C
C         CHECK CONVERGENCE
C
          if (abs (efd-efdx) .lt. 1.0e-05) return
C
C         SOLVE FOR NEW VE
C
          c4 = c3 - c1*(ifld/ve)**2
          c5 = 2.0*c1*ifld/ve*2 + c2
          c6 = efdx - c4*ve - c5*ifld
          ve = (efd - c5*ifld - c6)/c4
          if (ve .lt. 0.0) then
C
C           ERROR - ILLEGAL OPERATING RANGE
C
            write (errbuf(1),90) name,base,id,in,kc,ifld,ve
   90       format('0 CAUTION - NEGATIVE EXCITER VOLTAGE ',a8,2x,f5.1,
     1        2x,a1,' IN ',f9.6,' KC ',f9.6,' IFLD ',f9.6,' VE ',f9.6)
            call prterr('E',1)
         endif

        enddo
C
C       ERROR - CANNOT BE PROPERLY INITIALIZED
C
        write (errbuf(1),102) name,base,id,kc,ifld
 102    format('0',2x,a8,2x,f5.1,2x,a1,5x,'VE cannot be properly initial
     1ized. Check coefficient KC ',f9.6,' and field current ',f9.6)
        call prterr('E',1)
        imchn = 3
        return
        end


      subroutine pproj_mp(data,line,samp,lat,lon,imode,ind)

c DATA = standard 40-word geometry buffer (see subroutine CONVEV) for
c       Perspective case, except that word 37 = equatorial semi-minor axis

c LINE,SAMP = object space location of a point

c LAT,LON = planetary coordinates of point
c           (radians, planetocentric Lat., West Lon.)

c MODE:  1 = (LAT,LON) to (LINE,SAMP)   2 = (LINE,SAMP) to (LAT,LON)

c IND = return indicator.  0=success, 1=failure. (to coincide w/mp_routines)

c  31oct93  lwk  implemented tri-axial ellipsoid model with extra radius
c               in word 31 of DATA
c  15may94  lwk  fixed BOP test for triaxial ellipsoid using NAIF calls
c    jun96  pxa  cleaned up for use with MP routines, changed failure indicator
c               from 0 to 1, 3rd radius from word 31 to 37 in DATA
c    jul96  pxa  replaced naif/spice calls to 'surfnm','vsep', 'vnorm', and
c		 'halfpi' with relevant in-line code, to remove dependency of
c		 naif/ spice routines in mp_routines
c  30jul01  lwk  fixed bug in replacement of vnorm code

      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 CP(3),OP(3),CPP(3),OM(3,3),RS(3),xnorm(3),M
      REAL*8 EPS/1.E-6/
      REAL*8 U1(3),U2(3),VTEMP(3)
      REAL*4 LAT,LON,LINE,SAMP,DATA(*)
      DATA PI, RADDEG, DEGRAD / 3.141592653589793D0, 5.72957795130823D1,
     & 1.74532925199433D-2/
C
      HALFPI = PI/2.0
      IND = 1

      FL = DATA(27)	! camera focal length (mm)
      OAL = DATA(28)	! optical axis Line
      OAS = DATA(29)	! optical axis Sample
      SCALE = DATA(30)	! camera scale (pix/mm)

      RP = DATA(25)     ! polar radius
      RA = DATA(26)     ! equatorial semi-major radius

      RB = DATA(37)
c         check if RB is garbage, in which case assume oblate spheroid:
      IF (RB.LT.RP .OR. RB.GT.RA) RB = RA
      E1 = (RA/RP)
      E1 = E1*E1
      E2 = (RB/RP)
      E2 = E2*E2

c OM-matrix (Camera-to-Body coordinates) and RS-vector (body center to camera)
c are stored in the first 24 words of the buffer:
c      CALL MVL(DATA,OM,72)
c      CALL MVL(DATA(19),RS,24)
      call mve(1,72,data,om,1,1)
      call mve(1,24,data(19),rs,1,1)
C
      IF(IMODE.EQ.2) GOTO 30
C     ....Here to convert (lat,lon) to (line,samp)

      RLAT = LAT
      RLON = LON
      CLAT = DCOS(RLAT)
      SLAT = DSIN(RLAT)
      CLON = DCOS(RLON)
      SLON = DSIN(RLON)
C          COMPUTE GEOCENTRIC RADIUS
      D1 = RP*RP*CLAT*CLAT
      RB2 = RB*RB
      RA2 = RA*RA
      CLN2 = CLON*CLON
      SLN2 = SLON*SLON
      SLT2 = SLAT*SLAT
      R = (RA*RB*RP)/DSQRT(D1*RB2*CLN2+D1*RA2*SLN2+RA2*RB2*SLT2)
      CP(1) = R*CLAT*CLON - RS(1)
      CP(2) = -R*CLAT*SLON - RS(2)
      CP(3) = R*SLAT - RS(3)
C
c  BOP test for triaxial ellipsoid
c  *******************************************************************
c  The following code replaces the functionality of 'surfnm','vsep',and
c  halfpi() routines. This needed to be done to remove spice/naif
c  dependencies from mp_routines
c  ******************************************************************
c      call surfnm( ra, rb, rp, op, xnorm)

c      note CP is -1 * vector from P to C, so reverse criterion:
c      ibop = 0
c      if ( vsep(cp,xnorm) .lt. halfpi()) ibop = 1

      op(1) = r*clat*clon
      op(2) = -r*clat*slon
      op(3) = r*slat

      M=MIN(RA,RB,RP)
      A1=M/RA
      B1=M/RB
      C1=M/RP

      XNORM(1) = OP(1)*(A1*A1)
      XNORM(2) = OP(2)*(B1*B1)
      XNORM(3) = OP(3)*(C1*C1)

      VMAX1 = MAX(DABS(XNORM(1)),DABS(XNORM(2)),DABS(XNORM(3)))
      IF (VMAX1 .EQ. 0.) THEN
	VNORM1 = 0.
      ELSE
	VNORM1 = VMAX1*DSQRT((XNORM(1)/VMAX1)**2 + (XNORM(2)/VMAX1)**2 +
     &			(XNORM(3)/VMAX1)**2)
      END IF
      VMAG1 = VNORM1
      IF (VMAG1 .GT. 0.) THEN
	XNORM(1) = XNORM(1)/VMAG1
        XNORM(2) = XNORM(2)/VMAG1
        XNORM(3) = XNORM(3)/VMAG1
      ELSE
	XNORM(1) = 0.
	XNORM(2) = 0.
	XNORM(3) = 0.
      END IF
      ibop = 0
c     Now compute vsep(cp,xnorm), and assign it a value
      VMAX2 = MAX(DABS(CP(1)),DABS(CP(2)),DABS(CP(3)))
      IF (VMAX2 .EQ. 0.) THEN
	VNORM2 = 0.
      ELSE
	VNORM2 = VMAX2*DSQRT((CP(1)/VMAX2)**2 + (CP(2)/VMAX2)**2 +
     &			(CP(3)/VMAX2)**2)
      END IF
      VMAG2 = VNORM2
      IF (VMAG2 .GT. 0.) THEN
	U1(1) = CP(1)/VMAG2
	U1(2) = CP(2)/VMAG2
	U1(3) = CP(3)/VMAG2
      ELSE
	U1(1) = 0.
	U1(2) = 0.
	U1(3) = 0.
      END IF
      IF (VMAG2 .EQ. 0.) THEN
	VSEP1 = 0.
      END IF

      VMAX3 = MAX(DABS(XNORM(1)),DABS(XNORM(2)),DABS(XNORM(3)))
      IF (VMAX3 .EQ. 0.) THEN
	VNORM3 = 0.
      ELSE
	VNORM3 = VMAX3*DSQRT((XNORM(1)/VMAX3)**2 + (XNORM(2)/VMAX3)**2 +
     &			(XNORM(3)/VMAX3)**2)
      ENDIF
      VMAG3 = VNORM3
      IF (VMAG3 .GT. 0.) THEN
	U2(1) = XNORM(1)/VMAG3
	U2(2) = XNORM(2)/VMAG3
	U2(3) = XNORM(3)/VMAG3
      ELSE
	U2(1) = 0.
	U2(2) = 0.
	U2(3) = 0.
      END IF
      IF (VMAG3 .EQ. 0.) THEN
	VSEP1 = 0.
      END IF
      VDOT1 = U1(1)*U2(1) + U1(2)*U2(2) + U1(3)*U2(3)
      IF (VDOT1 .EQ. 0.) THEN
	VSEP1 = PI/2.0
      ELSE
        VTEMP(1) = U1(1) - U2(1)
        VTEMP(2) = U1(2) - U2(2)
        VTEMP(3) = U1(3) - U2(3)
        VMAX4 = MAX(DABS(VTEMP(1)),DABS(VTEMP(2)),DABS(VTEMP(3)))
        IF (VMAX4 .EQ. 0.) THEN
          VNORM4 = 0.
        ELSE
          VNORM4 = VMAX4*DSQRT((VTEMP(1)/VMAX4)**2 + (VTEMP(2)/VMAX4)**2 +
     &                         (VTEMP(3)/VMAX4)**2)
        END IF
        IF (VDOT1 .GT. 0.) THEN
	  VSEP1 = 2.0 * ASIN(0.5 * VNORM4)
        ELSE 				! VDOT1 .LT. 0.
	  VSEP1 = PI - 2.0*ASIN(0.5*VNORM4)
        END IF
      END IF
      IF (VSEP1 .LT. HALFPI) IBOP=1
c
c  *****************************************************************
c
      DO 20 I=1,3
      D1 = 0.D0
      DO 10 J=1,3
   10 D1 = D1 + OM(I,J)*CP(J)
   20 CPP(I) = D1
C
      S = FL*SCALE/CPP(3)
      LINE = OAL + S*CPP(2)
      SAMP = OAS + S*CPP(1)
      IND = IBOP
      RETURN
C
C     ....Here to convert (line,samp) to lat,lon)

   30 X = SAMP - OAS

      Y = LINE - OAL
      Z = FL*SCALE
C
      DO 40 I=1,3
   40 CP(I) = OM(1,I)*X + OM(2,I)*Y + OM(3,I)*Z
C
      A = E2*CP(1)*CP(1) + E1*CP(2)*CP(2) + E1*E2*CP(3)*CP(3)
      B = E2*CP(1)*RS(1) + E1*CP(2)*RS(2) + E1*E2*CP(3)*RS(3)
      C = E2*RS(1)*RS(1) + E1*RS(2)*RS(2) + E1*E2*RS(3)*RS(3)
     &   - E1*E2*RP*RP
      D = B*B - A*C
      IF (D.lt.0.) return
C
      IND = 0
      S = (-B-DSQRT(D))/A
C
      DO I=1,3
        OP(I) = S*CP(I) + RS(I)
      ENDDO
C
      X = OP(1)
      Y = OP(2)
      Z = OP(3)
      X1 = DABS(X)
      Y1 = DABS(Y)
      Z1 = DABS(Z)
      D = DSQRT(X*X+Y*Y)
      IF(D.LT.Z1*EPS) GOTO 98
      LAT = DATAN(Z/D)*RADDEG         ! GEOCENTRIC LAT.
      LAT = LAT*DEGRAD
c      ENDIF
      IF(Y1.LT.X1*EPS) GOTO 96
      IF(X1.LT.Y1*EPS) GOTO 94
      LON = 360. - DATAN2(Y,X)*RADDEG
      LON = LON*DEGRAD
c      IF(LON.GT.360.) LON=LON-360.
      IF(LON.GT.(2.*PI)) LON=LON-(2.*PI)
      RETURN
C
   94 LON = 270.
      LON = LON*DEGRAD
c      IF(Y.LT.0.) LON=90.
      IF(Y.LT.0) LON=PI/2.
      RETURN
   96 LON = 0.
      LON = LON*DEGRAD
c      IF(X.LT.0.) LON=180.
      IF(X.LT.0.) LON=PI
      RETURN
C
   98 LAT = 90.
      LAT = LAT*DEGRAD
      IF(Z.LT.0.) LAT=-LAT
      LON = 0.
      LON = LON*DEGRAD
      RETURN
      END


PROGRAM my_first_program

!  Purpose:
!    To illustrate some of the basic features of a Fortran program.
!

! Declare the variables used in this program.
INTEGER :: i, j, k             ! All variables are integers

! Get two values to store in variables i and j
WRITE (*,*) 'Enter the numbers to multiply: '
READ (*,*) i, j

! Multiply the numbers together
k = i * j

!  Write out the result.
WRITE (*,*) 'Result = ', k

!  Finish up.
STOP
END PROGRAM my_first_program


!*==cgelq.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CGELQ
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK,
!                         INFO )
!
!       .. Scalar Arguments ..
!       INTEGER           INFO, LDA, M, N, TSIZE, LWORK
!       ..
!       .. Array Arguments ..
!       COMPLEX           A( LDA, * ), T( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CGELQ computes an LQ factorization of a complex M-by-N matrix A:
!>
!>    A = ( L 0 ) *  Q
!>
!> where:
!>
!>    Q is a N-by-N orthogonal matrix;
!>    L is a lower-triangular M-by-M matrix;
!>    0 is a M-by-(N-M) zero matrix, if M < N.
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and below the diagonal of the array
!>          contain the M-by-min(M,N) lower trapezoidal matrix L
!>          (L is lower triangular if M <= N);
!>          the elements above the diagonal are used to store part of the
!>          data structure to represent Q.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] T
!> \verbatim
!>          T is COMPLEX array, dimension (MAX(5,TSIZE))
!>          On exit, if INFO = 0, T(1) returns optimal (or either minimal
!>          or optimal, if query is assumed) TSIZE. See TSIZE for details.
!>          Remaining T contains part of the data structure used to represent Q.
!>          If one wants to apply or construct Q, then one needs to keep T
!>          (in addition to A) and pass it to further subroutines.
!> \endverbatim
!>
!> \param[in] TSIZE
!> \verbatim
!>          TSIZE is INTEGER
!>          If TSIZE >= 5, the dimension of the array T.
!>          If TSIZE = -1 or -2, then a workspace query is assumed. The routine
!>          only calculates the sizes of the T and WORK arrays, returns these
!>          values as the first entries of the T and WORK arrays, and no error
!>          message related to T or WORK is issued by XERBLA.
!>          If TSIZE = -1, the routine calculates optimal size of T for the
!>          optimum performance and returns this value in T(1).
!>          If TSIZE = -2, the routine calculates minimal size of T and
!>          returns this value in T(1).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          (workspace) COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) contains optimal (or either minimal
!>          or optimal, if query was assumed) LWORK.
!>          See LWORK for details.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If LWORK = -1 or -2, then a workspace query is assumed. The routine
!>          only calculates the sizes of the T and WORK arrays, returns these
!>          values as the first entries of the T and WORK arrays, and no error
!>          message related to T or WORK is issued by XERBLA.
!>          If LWORK = -1, the routine calculates optimal size of WORK for the
!>          optimal performance and returns this value in WORK(1).
!>          If LWORK = -2, the routine calculates minimal size of WORK and
!>          returns this value in WORK(1).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \par Further Details
!  ====================
!>
!> \verbatim
!>
!> The goal of the interface is to give maximum freedom to the developers for
!> creating any LQ factorization algorithm they wish. The triangular
!> (trapezoidal) L has to be stored in the lower part of A. The lower part of A
!> and the array T can be used to store any relevant information for applying or
!> constructing the Q factor. The WORK array can safely be discarded after exit.
!>
!> Caution: One should not expect the sizes of T and WORK to be the same from one
!> LAPACK implementation to the other, or even from one execution to the other.
!> A workspace query (for T and WORK) is needed at each execution. However,
!> for a given execution, the size of T and WORK are fixed and will not change
!> from one query to the next.
!>
!> \endverbatim
!>
!> \par Further Details particular to this LAPACK implementation:
!  ==============================================================
!>
!> \verbatim
!>
!> These details are particular for this LAPACK implementation. Users should not
!> take them for granted. These details may change in the future, and are not likely
!> true for another LAPACK implementation. These details are relevant if one wants
!> to try to understand the code. They are not part of the interface.
!>
!> In this version,
!>
!>          T(2): row block size (MB)
!>          T(3): column block size (NB)
!>          T(6:TSIZE): data structure needed for Q, computed by
!>                           CLASWLQ or CGELQT
!>
!>  Depending on the matrix dimensions M and N, and row and column
!>  block sizes MB and NB returned by ILAENV, CGELQ will use either
!>  CLASWLQ (if the matrix is short-and-wide) or CGELQT to compute
!>  the LQ factorization.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CGELQ(M,N,A,Lda,T,Tsize,Work,Lwork,Info)
      IMPLICIT NONE
!*--CGELQ173
!
!  -- LAPACK computational routine (version 3.9.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
!     November 2019
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , M , N , Tsize , Lwork
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*) , T(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , lminws , mint , minw
      INTEGER mb , nb , mintsz , nblcks , lwmin , lwopt , lwreq
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL CGELQT , CLASWLQ , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN , MOD
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      EXTERNAL ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
!
      lquery = (Tsize==-1 .OR. Tsize==-2 .OR. Lwork==-1 .OR. Lwork==-2)
!
      mint = .FALSE.
      minw = .FALSE.
      IF ( Tsize==-2 .OR. Lwork==-2 ) THEN
         IF ( Tsize/=-1 ) mint = .TRUE.
         IF ( Lwork/=-1 ) minw = .TRUE.
      ENDIF
!
!     Determine the block size
!
      IF ( MIN(M,N)>0 ) THEN
         mb = ILAENV(1,'CGELQ ',' ',M,N,1,-1)
         nb = ILAENV(1,'CGELQ ',' ',M,N,2,-1)
      ELSE
         mb = 1
         nb = N
      ENDIF
      IF ( mb>MIN(M,N) .OR. mb<1 ) mb = 1
      IF ( nb>N .OR. nb<=M ) nb = N
      mintsz = M + 5
      IF ( nb<=M .OR. N<=M ) THEN
         nblcks = 1
      ELSEIF ( MOD(N-M,nb-M)==0 ) THEN
         nblcks = (N-M)/(nb-M)
      ELSE
         nblcks = (N-M)/(nb-M) + 1
      ENDIF
!
!     Determine if the workspace size satisfies minimal size
!
      IF ( (N<=M) .OR. (nb<=M) .OR. (nb>=N) ) THEN
         lwmin = MAX(1,N)
         lwopt = MAX(1,mb*N)
      ELSE
         lwmin = MAX(1,M)
         lwopt = MAX(1,mb*M)
      ENDIF
      lminws = .FALSE.
      IF ( (Tsize<MAX(1,mb*M*nblcks+5) .OR. Lwork<lwopt) .AND.          &
     &     (Lwork>=lwmin) .AND. (Tsize>=mintsz) .AND. (.NOT.lquery) )   &
     &     THEN
         IF ( Tsize<MAX(1,mb*M*nblcks+5) ) THEN
            lminws = .TRUE.
            mb = 1
            nb = N
         ENDIF
         IF ( Lwork<lwopt ) THEN
            lminws = .TRUE.
            mb = 1
         ENDIF
      ENDIF
      IF ( (N<=M) .OR. (nb<=M) .OR. (nb>=N) ) THEN
         lwreq = MAX(1,mb*N)
      ELSE
         lwreq = MAX(1,mb*M)
      ENDIF
!
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -4
      ELSEIF ( Tsize<MAX(1,mb*M*nblcks+5) .AND. (.NOT.lquery) .AND.     &
     &         (.NOT.lminws) ) THEN
         Info = -6
      ELSEIF ( (Lwork<lwreq) .AND. (.NOT.lquery) .AND. (.NOT.lminws) )  &
     &         THEN
         Info = -8
      ENDIF
!
      IF ( Info==0 ) THEN
         IF ( mint ) THEN
            T(1) = mintsz
         ELSE
            T(1) = mb*M*nblcks + 5
         ENDIF
         T(2) = mb
         T(3) = nb
         IF ( minw ) THEN
            Work(1) = lwmin
         ELSE
            Work(1) = lwreq
         ENDIF
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGELQ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( MIN(M,N)==0 ) RETURN
!
!     The LQ Decomposition
!
      IF ( (N<=M) .OR. (nb<=M) .OR. (nb>=N) ) THEN
         CALL CGELQT(M,N,mb,A,Lda,T(6),mb,Work,Info)
      ELSE
         CALL CLASWLQ(M,N,mb,nb,A,Lda,T(6),mb,Work,Lwork,Info)
      ENDIF
!
      Work(1) = lwreq
!
!
!     End of CGELQ
!
      END SUBROUTINE CGELQ


*deck l2opxv
      subroutine l2opxv( lmn, v, itl, itu, lmnv, lenscr, scr, eval,
     & leig )
c
c  compute the matrix vector product, (L^2) * v, in an unnormalized
c  cartesian basis, and determine if v(*) is an eigenvector of the
c  total angular momentum operator.
c
c  input:
c  lmn = (l + m + n) where l, m, and n are the exponents of x, y, and z
c        respectively.  lmn=0 for cartesian "s" functions, 1 for
c        cartesian "p" functions, 2 for cartesian "d" functions, etc.
c  v(1:xyzdim) = input vector.  the elements are coefficients of the
c              cartesian basis functions (x**l * y**m * z**n).
c              where xyzdim = ((lmn + 1) * (lmn + 2))/2
c  lmnv(1:3,1:lmnvmx) = cartesian exponents of each basis function.
c  lenscr = scratch vector length.
c  scr(1:lenscr) = scratch work vector.  This must be at least as large
c                  as the cartesian subspace dimension.
c                  lenscr >= xyzdim
c
c  output:
c  eval = vector expectation value = <v| L^2 |v> / <v|v>
c  leig = eigenvector return code.
c       = -4 for vector norm error.
c       = -3 for lmnv(*,*) inconsistency.
c       = -2 for lenscr error.
c       = -1 if v(*) is not an eigenvector of L^2
c       = principal quantum number if v(*) is an eigenvector.
c         0 for s-type vectors, 1 for p-type vectors, etc.
c         the eigenvalue is given by (leig*(leig+1)) to within numerical
c         precision.
c  28-oct-96 account for nonorthogonality of cartesian gaussians (rmp)
c  11-jun-91 written by ron shepard with suggestions from r. m. pitzer.
c
      implicit logical(a-z)
c
c     # dummy:
c     integer lmn, lenv, lenscr, leig
      integer itl, itu, lmn, lenscr, leig
      integer lmnv(3,*)
      real*8 eval
      real*8 v(*), scr(*)
c
c     # local:
      integer l, m, n, i, j, it, jt, xyzdim, ll, mm, nn, p, q
      real*8 vi, rnorm, vnorm2
c
c     # small is used to determine if a vector is close enough to be
c     #       called an eigenvector.  this should be about 1000x the
c     #       machine epsilon to avoid sqrt() precision problems.
c
      real*8    zero,     one,     two,     fourth,        small
      parameter(zero=0d0, one=1d0, two=2d0, fourth=0.25d0, small=1d-10)
c
c     # bummer error types.
      integer    wrnerr,  nfterr,  faterr
      parameter (wrnerr=0,nfterr=1,faterr=2)
c
      integer  iodfac
      external iodfac
c
c     # the [l,m,n] basis function is assigned the internal index:
c     #  (lx*(lx+1))/2 + n + 1   with lx=(lmn-l)=(m+n)
c     # this convention is inconsistent with the rest of this program,
c     # but it is used anyway since it is convenient and since the
c     # computed results are local.
c
      integer llp1
      llp1(l) = (l * (l + 1)) / 2 + 1
c
      leig = -1
      eval = -one
c
c     # check to make sure scr(*) is large enough.
      xyzdim = llp1( lmn) + lmn
      if ( xyzdim .gt. lenscr ) then
         call bummer('l2opxv: need larger scr(*), (xyzdim-lenscr)=',
     &    (xyzdim-lenscr), wrnerr )
         leig = -2
         return
      endif
c
c     # initialize the scratch vector.
      call wzero(xyzdim,scr,1)
c
c     # compute the matrix-vector product and the vector norm.
c     # matrix elements of lop(*,*) are computed from the operator
c     # definition in cartesian space.
c
      vnorm2 = zero
      do 30 it = itl, itu
         i = it - (itl - 1)
         l = lmnv(1,it)
         m = lmnv(2,it)
         n = lmnv(3,it)
         vi = v(i)
         do 20 jt = itl, it-1
            j = jt - (itl - 1)
            vnorm2 = vnorm2 + (two * vi) * v(j) *
     &       iodfac(l,lmnv(1,jt),m,lmnv(2,jt),n,lmnv(3,jt))
   20    continue
         vnorm2 = vnorm2 + vi * vi * iodfac(l,l,m,m,n,n)
c
         if ( (l+m+n) .ne. lmn ) then
c           # inconsistent exponents in the basis function.
            call bummer('l2opxv: (l+m+n-lmn)=', (l+m+n-lmn), wrnerr )
            leig = -3
            return
         endif
c
c        # L^2 is sparse in this representation.  each vi contributes
c        # to, at most, only 7 elements in the matrix-vector product.
c
         if ( l .ge. 2 ) then
c           # include -l*(l-1) * ( [l-2,m,n+2] + [l-2,m+2,n] ) terms.
            ll = l * (l - 1)
            p = llp1( lmn - l + 2 ) + n
            scr(p) = scr(p) - vi * (ll)
            p = p + 2
            scr(p) = scr(p) - vi * (ll)
         endif
c
         if ( m .ge. 2 ) then
c           # include -m*(m-1) * ( [l,m-2,n+2] + [l+2,m-2,n] ) terms.
            mm = m * (m - 1)
            p = llp1( lmn - l ) + n + 2
            scr(p) = scr(p) - vi * (mm)
            p = llp1( lmn - l - 2 ) + n
            scr(p) = scr(p) - vi * (mm)
         endif
c
         if ( n .ge. 2 ) then
c           # include -n*(n-1) * ( [l,m+2,n-2] + [l+2,m,n-2] ) terms.
            nn = n * (n - 1)
            p = llp1( lmn - l ) + n - 2
            scr(p) = scr(p) - vi * (nn)
            p = llp1( lmn - l - 2 ) + n - 2
            scr(p) = scr(p) - vi * (nn)
         endif
c
c        # include the 2*(l*m+l*n+m*n+l+m+n)*[l,m,n] diagonal term.
c
         p = llp1( lmn - l ) + n
         scr(p) = scr(p) + vi * (2 * (l * (m + n) + m * n + l + m + n))
   30 continue
c
      if ( vnorm2 .le. small ) then
         call bummer('l2mxv: small vector norm, lnm=', lmn, wrnerr)
         leig = -4
         return
      endif
c
c     # compute the expectation value.
c
      eval  = zero
      do 50 it = itl, itu
         i = it - (itl - 1)
         l = lmnv(1,it)
         m = lmnv(2,it)
         n = lmnv(3,it)
         p = llp1( lmn - l ) + n
         do 40 jt = itl, itu
            j = jt - (itl - 1)
            eval = eval + v(j) * scr(p) *
     &                  iodfac(l,lmnv(1,jt),m,lmnv(2,jt),n,lmnv(3,jt))
   40    continue
   50 continue
      eval = eval / vnorm2
c
c     # compute the residual norm.
c     #
      rnorm = zero
c
      do 70 it = itl, itu
         i = it - (itl - 1)
         l = lmnv(1,it)
         m = lmnv(2,it)
         n = lmnv(3,it)
         p = llp1( lmn - l ) + n
         do 60 jt = itl, it-1
            j = jt - (itl - 1)
            q = llp1( lmn - lmnv(1,jt) ) + lmnv(3,jt)
            rnorm = rnorm + two * ( scr(p) - eval * v(i) ) *
     &                            ( scr(q) - eval * v(j) ) *
     &                iodfac(l,lmnv(1,jt),m,lmnv(2,jt),n,lmnv(3,jt))
   60    continue
        rnorm = rnorm + (scr(p) - eval * v(i))**2 * iodfac(l,l,m,m,n,n)
   70 continue
c
c     # normalize w.r.t. |v|=1.
      rnorm = rnorm / vnorm2
c
      rnorm = sqrt( rnorm )
      if ( rnorm .gt. small ) then
c
c        # v(*) is not an eigenvector.
c
         leig = -1
      else
c
c        # v(*) is an eigenvector.
c
c        # determine leig such that eval = leig*(leig+1)
c
c        # the following assignment should truncate to the
c        # next smaller integer value...
         leig = ( sqrt( eval + fourth ) )
      endif
c
      return
      end


C
C
*+ do_chi_map

       subroutine do_chi_map(map_array,status)
C      ---------------------------------------
C
C construct a position-angle/error map from a Q and a U map
C
C Given:
C   map data
       real*4        map_array(*)
C Returned:
C   error status word
       integer       status
C
C A correction for RICEAN bias is applied
*-
       include '../include/error_file_full.inc'
C
       integer    imapq, ip_mapq, imapu, ip_mapu, iwarn,
     *            minirt(8), iu, iv, imape, ip_mape, imapo,
     *            ip_mapo, poln_code
       real*4     invtan, val_lim, val_chi, val_mi, p_noise,
     *            ricean_bias, gate, blank_value, frequency
       character  name*16, unit*16

C check status on entry
       if (status.ne.0) return

C find q map
       call map_getmap('Map-Q : ','Default-Map','READ',imapq,status)
C find u map
       call map_getmap('Map-U : ','Default-Map','READ',imapu,status)

C input data
       call io_getr('Noise on Q/U maps : ','0.0',p_noise,status)
       call io_getr('Gate (mI >= gate*noise) : ','3.0',gate,status)
       if (status.ne.0) goto 999

C check redtape
       iwarn = 2
       call redt_comp(imapq,imapu,iwarn,status)
       if (status.ne.0. .or. iwarn.gt.5) goto 999

C check input polarizations
       call redt_load(imapq,status)
       call ennull( blank_value, status )
       call entype( frequency, poln_code, name, unit, status )
       if (poln_code.ne.2) then
         call cmd_wrerr('CHI-MAP','Invalid polarization code')
         call cmd_wrerr('CHI-MAP','Error on input Q-map')
         status = ill_poln
       end if
       call redt_load(imapu,status)
       call entype( frequency, poln_code, name, unit, status )
       if (poln_code.ne.3) then
         call cmd_wrerr('CHI-MAP','Invalid polarization code')
         call cmd_wrerr('CHI-MAP','Error on input U-map')
         status = ill_poln
       end if
       if (status.ne.0) goto 999

C allocate maps
       call map_alloc_in(imapq,'SEQUENTIAL',map_array,ip_mapq,status)
       call map_alloc_in(imapu,'SEQUENTIAL',map_array,ip_mapu,status)
       call map_alloc_out(0,0,'SEQUENTIAL',imapo,ip_mapo,status)
       call map_alloc_out(0,0,'SEQUENTIAL',imape,ip_mape,status)

C construct the mi map
       ricean_bias = p_noise**2
       val_lim = (p_noise*gate)**2
       call enminirt(minirt,status)
       do iv = minirt(3),minirt(4),-1
         call map_row_read(imapq,iv,map_array,ip_mapq,status)
         call map_row_read(imapu,iv,map_array,ip_mapu,status)
         do iu = 1,minirt(5)
           val_mi = map_array(ip_mapq+iu-1)**2
     *            + map_array(ip_mapu+iu-1)**2 - ricean_bias
           val_chi =
     *        invtan(map_array(ip_mapu+iu-1),map_array(ip_mapq+iu-1))
           val_chi = val_chi*0.5
           if (val_mi.gt.val_lim .and. val_mi.gt.0.0) then
             map_array(ip_mape+iu-1) = 0.5*p_noise/val_mi
             map_array(ip_mapo+iu-1) = val_chi
           else
             map_array(ip_mape+iu-1) = blank_value
             map_array(ip_mapo+iu-1) = blank_value
           end if
         end do
         call map_row_write(imapo,iv,map_array,ip_mapo,status)
         call map_row_write(imape,iv,map_array,ip_mape,status)
       end do

C update redtapes
       call adredt('created','CHI-ERR',status)
       call redt_update('CHI',11,-1.0,
     *                  'Error Pos-Angle','RADIANS',status)

C end error map
999    call map_end_alloc(imape,map_array,status)

C main map
       call adredt('created','CHI-MAP',status)
       call redt_update('CHI',11,-1.0,
     *                  'Position Angle','RADIANS',status)
       call map_end_alloc(imapo,map_array,status)

C input maps
       call map_end_alloc(imapq,map_array,status)
       call map_end_alloc(imapu,map_array,status)

C check status value
       call cmd_err(status,'CHI-MAP','Failed')
       end


! -*- F90 -*-

      subroutine MRST98evolve(x,Q,pdf)
      implicit real*8(a-h,o-z)
      include 'parmsetup.inc'
      character*16 name(nmxset)
      integer nmem(nmxset),ndef(nmxset),mmem
      integer nset
      common/NAME/name,nmem,ndef,mmem
      parameter(nx=49,nq=37,ntenth=23,np=8,members=5)
      double precision gridx(nmxgridx),gridq(nmxgridq)
      integer ngridx,ngridq,jx,jq
      real*8 pdf(-6:6)
      real*8 f(0:members,np,nx,nq+1)
      real*8 qq(nq),xx(nx),xxin(nx),g(np),n0(np)
      data xxin/1d-5,2d-5,4d-5,6d-5,8d-5,                               &
     &              1d-4,2d-4,4d-4,6d-4,8d-4,                           &
     &              1d-3,2d-3,4d-3,6d-3,8d-3,                           &
     &              1d-2,1.4d-2,2d-2,3d-2,4d-2,6d-2,8d-2,               &
     &           .1d0,.125d0,.15d0,.175d0,.2d0,.225d0,.25d0,.275d0,     &
     &           .3d0,.325d0,.35d0,.375d0,.4d0,.425d0,.45d0,.475d0,     &
     &           .5d0,.525d0,.55d0,.575d0,.6d0,.65d0,.7d0,.75d0,        &
     &           .8d0,.9d0,1d0/
      data qq/1.25d0,1.5d0,2d0,2.5d0,3.2d0,4d0,5d0,6.4d0,8d0,1d1,       &
     &        1.2d1,1.8d1,2.6d1,4d1,6.4d1,1d2,                          &
     &        1.6d2,2.4d2,4d2,6.4d2,1d3,1.8d3,3.2d3,5.6d3,1d4,          &
     &        1.8d4,3.2d4,5.6d4,1d5,1.8d5,3.2d5,5.6d5,1d6,              &
     &        1.8d6,3.2d6,5.6d6,1d7/
      data xmin,xmax,qsqmin,qsqmax/1d-5,1d0,1.25d0,1d7/
      data n0/3,4,5,9,9,9,9,9/
      save
!
      xsave=x
      qsq = q*q
      q2save=qsq
!
      if(x.lt.xmin) x=xmin
      if(x.gt.xmax) x=xmax
      if(qsq.lt.qsqmin)        qsq=qsqmin
      if(qsq.gt.qsqmax)        qsq=qsqmax
!
      xxx=x
      if(x.lt.xx(ntenth)) xxx=dlog10(x/xx(ntenth))+xx(ntenth)
      n=0
   70 n=n+1
      if(xxx.gt.xx(n+1)) goto 70
      a=(xxx-xx(n))/(xx(n+1)-xx(n))
      m=0
   80 m=m+1
      if(qsq.gt.qq(m+1)) goto 80
      b=(qsq-qq(m))/(qq(m+1)-qq(m))
      do 60 i=1,np
      g(i)= (1d0-a)*(1d0-b)*f(imem,i,n,m)+(1d0-a)*b*f(imem,i,n,m+1)     &
     &          +       a*(1d0-b)*f(imem,i,n+1,m)+a*b*f(imem,i,n+1,m+1)
      if(n.ge.ntenth) goto 65
      if(i.eq.5.or.i.eq.7) goto 65
          fac=(1d0-b)*f(imem,i,ntenth,m)+b*f(imem,i,ntenth,m+1)
           g(i)=fac*10d0**(g(i)-fac)
   65 continue
      g(i)=g(i)*(1d0-x)**n0(i)
   60 continue
      upv=g(1)
      dnv=g(2)
      usea=g(4)
      dsea=g(8)
      str=g(6)
      chm=g(5)
      glu=g(3)
      bot=g(7)
!
      pdf(0)  = glu
      pdf(1)  = dnv+dsea
      pdf(-1) = dsea
      pdf(2)  = upv+usea
      pdf(-2) = usea
      pdf(3)  = str
      pdf(-3) = str
      pdf(4)  = chm
      pdf(-4) = chm
      pdf(5)  = bot
      pdf(-5) = bot
      pdf(6)  = 0.0d0
      pdf(-6) = 0.0d0

      x=xsave
      qsq=q2save
      return
!
      entry MRST98getgrid(nset,ngridx,ngridq,gridx,gridq)
      do jx=1,nx
          gridx(jx)=xx(jx)
      enddo
      do jq=1,nq
          gridq(jq)=qq(jq)
      enddo
      ngridx=nx
      ngridq=nq
      return

      entry MRST98read(nset)
      read(1,*)nmem(nset),ndef(nset)
! - first resotre the xx array
      do j=1,nx
        xx(j)=xxin(j)
      enddo
! - next read in the data points
      do nm = 0,nmem(nset)
        do 20 n=1,nx-1
        do 20 m=1,nq
        read(1,50)f(nm,1,n,m),f(nm,2,n,m),f(nm,3,n,m),f(nm,4,n,m),      &
     &                  f(nm,5,n,m),f(nm,7,n,m),f(nm,6,n,m),f(nm,8,n,m)
! notation: 1=uval 2=val 3=glue 4=usea 5=chm 6=str 7=btm 8=dsea
        do 25 i=1,np
   25        f(nm,i,n,m)=f(nm,i,n,m)/(1d0-xx(n))**n0(i)
   20   continue
!        write(*,*)'PDF set ',nm,' first element ',f(nm,1,1,1)
        do 31 j=1,ntenth-1
!        xx(j)=dlog10(xx(j)/xx(ntenth))+xx(ntenth)
        do 31 i=1,8
        if(i.eq.5.or.i.eq.7) goto 31
        do 30 k=1,nq
   30   f(nm,i,j,k)=dlog10(f(nm,i,j,k)/f(nm,i,ntenth,k))                &
     &              +f(nm,i,ntenth,k)
   31   continue
   50   format(8f10.5)
        do 40 i=1,np
        do 40 m=1,nq
   40 f(nm,i,nx,m)=0d0
       enddo
      do 32 j=1,ntenth-1
        xx(j)=dlog10(xx(j)/xx(ntenth))+xx(ntenth)
   32 continue
      return
!
      entry MRST98alfa(alfas,Qalfa)
        call alphamrs(5,alfas,Qalfa)
      return
!
      entry MRST98init(Eorder,Q2fit)
      return
!
      entry MRST98pdf(mem)
!      if(mem.eq.0) mem=ndef
      imem = mem
!      print *,imem

      return
!
      END


      SUBROUTINE HIRECT(IM)
*
*
*       Rectification of hierarchical binary.
*       -------------------------------------
*
      INCLUDE 'common6.h'
      COMMON/BINARY/  CM(4,MMAX),XREL(3,MMAX),VREL(3,MMAX),
     &                HM(MMAX),UM(4,MMAX),UMDOT(4,MMAX),TMDIS(MMAX),
     &                NAMEM(MMAX),NAMEG(MMAX),KSTARM(MMAX),IFLAGM(MMAX)
*
*
*       Include diagnostic error check.
      RB = 0.0
      UPR2 = 0.0
      TD2 = 0.0
      DO 5 K = 1,4
          RB = RB + UM(K,IM)**2
          UPR2 = UPR2 + UMDOT(K,IM)**2
          TD2 = TD2 + 2.0*UM(K,IM)*UMDOT(K,IM)
    5 CONTINUE
*
      ZMB = CM(1,IM) + CM(2,IM)
      HI = (2.0*UPR2 - ZMB)/RB
      ERR = (HI - HM(IM))/HI
      ZMU = CM(1,IM)*CM(2,IM)/ZMB
      DB = ZMU*(HI - HM(IM))
      IF (ABS(DB).GT.1.0D-08) THEN
      SEMI = -0.5*ZMB/HM(IM)
      ECC2 = (1.0 - RB/SEMI)**2 + TD2**2/(ZMB*SEMI)
      ECC = SQRT(ECC2)
      RA = RB/SEMI
      WRITE (16,3) TTOT, NAMEG(IM), KSTARM(IM), ECC, RA, HM(IM), DB, ERR
    3 FORMAT (' HIRECT:   T NM K* E R/A H DB DH/H ',
     &                    F9.3,I6,I4,F8.4,F8.4,F9.2,1P,2E10.1)
      CALL FLUSH(16)
      END IF
*       Initialize iteration counter for difficult case (SJA 10/97).
      ITER = 0
*
*       Form square regularized velocity for the explicit binding energy.
   10 RB = 0.0D0
      UPR2 = 0.0
      DO 15 K = 1,4
          RB = RB + UM(K,IM)**2
          UPR2 = UPR2 + UMDOT(K,IM)**2
   15 CONTINUE
*
*       Form KS scaling factors from energy and angular momentum relation.
      A1 = 0.25D0*ZMB/UPR2
*       Solve for C1 from H = (2*U'*U'*C1**2 - M)/(U*U*C2**2) with C2 = 1/C1.
      A2 = A1**2 + 0.5D0*HM(IM)*RB/UPR2
*
*       Avoid negative round-off value on second try (NB! no change in CK).
      IF (ITER.EQ.2.AND.A2.LT.0.0) A2 = 0.0D0
*
*       Check for undefined case (circular orbit or eccentric anomaly = 90).
      IF (A2.GE.0.0D0) THEN
          IF (A1.LT.1.0) THEN
*       Choose square root sign from eccentric anomaly (e*cos(E) = 1 - R/a).
              C1 = SQRT(A1 + SQRT(A2))
          ELSE
              C1 = SQRT(A1 - SQRT(A2))
          END IF
          CK = 1.0
      ELSE
*       Adopt C1*C2 = CK for difficult case (Seppo's suggestion of 1991).
          C1 = 1.0
          CK = ZMB/SQRT(-8.0D0*HM(IM)*RB*UPR2)
          WRITE (6,20)  IM, KSTARM(IM), RB, HM(IM), UPR2, A2, CK-1.0
   20     FORMAT (' WARNING!    HIRECT    IM K* R H UPR2 A2 CK-1 ',
     &                                    2I4,1P,5E10.2)
          ITER = ITER + 1
      END IF
*
*       Specify KS coordinate scaling from angular momentum conservation.
      C2 = CK/C1
*
*       Transform KS variables to yield the prescribed elements.
      DO 25 K = 1,4
          UM(K,IM) = C2*UM(K,IM)
          UMDOT(K,IM) = C1*UMDOT(K,IM)
   25 CONTINUE
*
*       Improve solution by second iteration in case of CK procedure.
      ITER = ITER + 1
      IF (ITER.EQ.2) GO TO 10
*
      RETURN
*
      END


      subroutine specpack(fld,ndpts,JJ,KK,MM,idrstmpl,cpack,lcpack)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .                                       .
! SUBPROGRAM:    specpack
!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2002-12-19
!
! ABSTRACT: This subroutine packs a spectral data field using the complex
!   packing algorithm for spherical harmonic data as
!   defined in the GRIB2 Data Representation Template 5.51.
!
! PROGRAM HISTORY LOG:
! 2002-12-19  Gilbert
!
! USAGE:    CALL specpack(fld,ndpts,JJ,KK,MM,idrstmpl,cpack,lcpack)
!   INPUT ARGUMENT LIST:
!     fld()    - Contains the packed data values
!     ndpts    - The number of data values to pack
!     JJ       - J - pentagonal resolution parameter
!     KK       - K - pentagonal resolution parameter
!     MM       - M - pentagonal resolution parameter
!     idrstmpl - Contains the array of values for Data Representation
!                Template 5.51
!
!   OUTPUT ARGUMENT LIST:
!     cpack    - The packed data field (character*1 array)
!     lcpack   - length of packed field cpack().
!
! REMARKS: None
!
! ATTRIBUTES:
!   LANGUAGE: XL Fortran 90
!   MACHINE:  IBM SP
!
!$$$

      real,intent(in) :: fld(ndpts)
      integer,intent(in) :: ndpts,JJ,KK,MM
      integer,intent(inout) :: idrstmpl(*)
      character(len=1),intent(out) :: cpack(*)
      integer,intent(out) :: lcpack

      integer :: ifld(ndpts),Ts,tmplsim(5)
      real :: bscale,dscale,unpk(ndpts),tfld(ndpts)
      real,allocatable :: pscale(:)

      bscale = 2.0**real(-idrstmpl(2))
      dscale = 10.0**real(idrstmpl(3))
      nbits = idrstmpl(4)
      Js=idrstmpl(6)
      Ks=idrstmpl(7)
      Ms=idrstmpl(8)
      Ts=idrstmpl(9)

!
!   Calculate Laplacian scaling factors for each possible wave number.
!
      allocate(pscale(JJ+MM))
      tscale=real(idrstmpl(5))*1E-6
      do n=Js,JJ+MM
         pscale(n)=real(n*(n+1))**(tscale)
      enddo
!
!   Separate spectral coeffs into two lists; one to contain unpacked
!   values within the sub-spectrum Js, Ks, Ms, and the other with values
!   outside of the sub-spectrum to be packed.
!
      inc=1
      incu=1
      incp=1
      do m=0,MM
         Nm=JJ      ! triangular or trapezoidal
         if ( KK .eq. JJ+MM ) Nm=JJ+m          ! rhombodial
         Ns=Js      ! triangular or trapezoidal
         if ( Ks .eq. Js+Ms ) Ns=Js+m          ! rhombodial
         do n=m,Nm
            if (n.le.Ns .AND. m.le.Ms) then    ! save unpacked value
               unpk(incu)=fld(inc)         ! real part
               unpk(incu+1)=fld(inc+1)     ! imaginary part
               inc=inc+2
               incu=incu+2
            else                         ! Save value to be packed and scale
                                         ! Laplacian scale factor
               tfld(incp)=fld(inc)*pscale(n)         ! real part
               tfld(incp+1)=fld(inc+1)*pscale(n)     ! imaginary part
               inc=inc+2
               incp=incp+2
            endif
         enddo
      enddo

      deallocate(pscale)

      incu=incu-1
      if (incu .ne. Ts) then
         print *,'specpack: Incorrect number of unpacked values ',
     &           'given:',Ts
         print *,'specpack: Resetting idrstmpl(9) to ',incu
         Ts=incu
      endif
!
!  Add unpacked values to the packed data array in 32-bit IEEE format
!
      call mkieee(unpk,cpack,Ts)
      ipos=4*Ts
!
!  Scale and pack the rest of the coefficients
!
      tmplsim(2)=idrstmpl(2)
      tmplsim(3)=idrstmpl(3)
      tmplsim(4)=idrstmpl(4)
      call simpack(tfld,ndpts-Ts,tmplsim,cpack(ipos+1),lcpack)
      lcpack=lcpack+ipos
!
!  Fill in Template 5.51
!
      idrstmpl(1)=tmplsim(1)
      idrstmpl(2)=tmplsim(2)
      idrstmpl(3)=tmplsim(3)
      idrstmpl(4)=tmplsim(4)
      idrstmpl(9)=Ts
      idrstmpl(10)=1         ! Unpacked spectral data is 32-bit IEEE

      return
      end


c     ==================================================================
      subroutine setaux(mbc,mx,my,xlower,ylower,
     &                  dx,dy,maux,aux)
c     ==================================================================
c
c     # set auxiliary arrays
c
c     # acoustics in a heterogeneous medium:
c     #  aux(i,j,1) = density p in (i,j) cell
c     #  aux(i,j,2) = sound speed c in (i,j) cell
c
c
      use amr_module, only : NEEDS_TO_BE_SET
      use adjoint_module, only: innerprod_index

      implicit double precision (a-h,o-z)
      double precision aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)
      common /comaux/ p1,c1,p2,c2

      do j = 1-mbc,my+mbc
        do i = 1-mbc,mx+mbc
            xcell = xlower + (i-0.5d0)*dx

            if (aux(1,i,j) .eq. NEEDS_TO_BE_SET) then
                aux(innerprod_index,i,j) = 0.d0
            endif

            if (xcell .lt. 0.d0) then
                aux(1,i,j) = p1
                aux(2,i,j) = c1
            else
                aux(1,i,j) = p2
                aux(2,i,j) = c2
            endif
        enddo
      enddo

      return
      end


!
! Copyright (C) 2001-2003 PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!-----------------------------------------------------------------------
subroutine cryst_to_cart (nvec, vec, trmat, iflag)
  !-----------------------------------------------------------------------
  !
  !     This routine transforms the atomic positions or the k-point
  !     components from crystallographic to cartesian coordinates
  !     ( iflag=1 ) and viceversa ( iflag=-1 ).
  !     Output cartesian coordinates are stored in the input ('vec') array
  !
  !
  USE kinds, ONLY : DP
  implicit none
  !
  integer, intent(in) :: nvec, iflag
  ! nvec:  number of vectors (atomic positions or k-points)
  !        to be transformed from crystal to cartesian and vice versa
  ! iflag: gives the direction of the transformation
  real(DP), intent(in) :: trmat (3, 3)
  ! trmat: transformation matrix
  ! if iflag=1:
  !    trmat = at ,  basis of the real-space lattice,       for atoms   or
  !          = bg ,  basis of the reciprocal-space lattice, for k-points
  ! if iflag=-1: the opposite
  real(DP), intent(inout) :: vec (3, nvec)
  ! coordinates of the vector (atomic positions or k-points) to be
  ! transformed - overwritten on output
  !
  !    local variables
  !
  integer :: nv, kpol
  ! counter on vectors
  ! counter on polarizations
  real(DP) :: vau (3)
  ! workspace
  !
  !     Compute the cartesian coordinates of each vectors
  !     (atomic positions or k-points components)
  !
  do nv = 1, nvec
     if (iflag.eq.1) then
        do kpol = 1, 3
           vau (kpol) = trmat (kpol, 1) * vec (1, nv) + trmat (kpol, 2) &
                * vec (2, nv) + trmat (kpol, 3) * vec (3, nv)
        enddo
     else
        do kpol = 1, 3
           vau (kpol) = trmat (1, kpol) * vec (1, nv) + trmat (2, kpol) &
                * vec (2, nv) + trmat (3, kpol) * vec (3, nv)
        enddo
     endif
     do kpol = 1, 3
        vec (kpol, nv) = vau (kpol)
     enddo
  enddo
  !
  return
end subroutine cryst_to_cart


      program riters
c-----------------------------------------------------------------------
c test program for iters -- the basic iterative solvers
c
c     this program generates a sparse matrix using
c     GEN57PT and then solves a linear system with an
c     artificial rhs (the solution is a vector of (1,1,...,1)^T).
c-----------------------------------------------------------------------
c      implicit none
c      implicit real( kind = 8 ) (a-h,o-z)
      integer nmax, nzmax, maxits,lwk
      parameter (nmax=5000,nzmax=100000,maxits=60,lwk=nmax*40)
      integer ia(nmax),ja(nzmax),jau(nzmax),ju(nzmax),iw(nmax*3)
      integer ipar(16),nx,ny,nz,i,lfil,nwk,nrow,ierr
      real( kind = 8 )  a(nzmax),sol(nmax),rhs(nmax)
      real( kind = 8) au(nzmax),wk(nmax*40)
      real( kind = 8 )  xran(nmax), fpar(16), al(nmax)
      real( kind = 8 )  gammax,gammay,alpha,tol
      external gen57pt,cg,bcg,dbcg,bcgstab,tfqmr,gmres,fgmres,dqgmres
      external cgnr, fom, runrc, ilut
c
      common /func/ gammax, gammay, alpha
c-----------------------------------------------------------------------
c pde to be discretized is :
c---------------------------
c
c -Lap u + gammax exp (xy)delx u + gammay exp (-xy) dely u +alpha u
c
c where Lap = 2-D laplacean, delx = part. der. wrt x,
c dely = part. der. wrt y.
c gammax, gammay, and alpha are passed via the commun func.
c
c-----------------------------------------------------------------------
c
c data for PDE:
c
      nx = 6
      ny = 6
      nz = 1
      alpha  = 0.0
      gammax = 0.0
      gammay = 0.0
c
c     set the parameters for the iterative solvers
c
      ipar(2) = 2
      ipar(3) = 1
      ipar(4) = lwk
      ipar(5) = 10
      ipar(6) = maxits
      fpar(1) = 1.0D-5
      fpar(2) = 1.0D-10
c--------------------------------------------------------------
c call GEN57PT to generate matrix in compressed sparse row format
c
c     al(1:6) are used to store part of the boundary conditions
c     (see documentation on GEN57PT.)
c--------------------------------------------------------------
      al(1) = 0.0
      al(2) = 0.0
      al(3) = 0.0
      al(4) = 0.0
      al(5) = 0.0
      al(6) = 0.0
      nrow = nx * ny * nz
      call gen57pt(nx,ny,nz,al,0,nrow,a,ja,ia,ju,rhs)
      print *, 'RITERS: generated a finite difference matrix'
      print *, '        grid size = ', nx, ' X ', ny, ' X ', nz
      print *, '        matrix size = ', nrow
c
c     set-up the preconditioner ILUT(15, 1E-4)  ! new definition of lfil
c
      lfil = 3
      tol = 1.0D-4
      nwk = nzmax
      call ilut (nrow,a,ja,ia,lfil,tol,au,jau,ju,nwk,
     *     wk,iw,ierr)
      ipar(2) = 2
c
c     generate a linear system with known solution
c
      do i = 1, nrow
         sol(i) = 1.0D0
         xran(i) = 0.d0
      end do
      call amux(nrow, sol, rhs, a, ja, ia)
      print *, ' '
      print *, '	*** CG ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     cg)
      print *, ' '
      print *, '	*** BCG ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     bcg)
      print *, ' '
      print *, '	*** DBCG ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     dbcg)
      print *, ' '
      print *, '	*** CGNR ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     cgnr)
      print *, ' '
      print *, '	*** BCGSTAB ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     bcgstab)
      print *, ' '
      print *, '	*** TFQMR ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     tfqmr)
      print *, ' '
      print *, '	*** FOM ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     fom)
      print *, ' '
      print *, '	*** GMRES ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     gmres)
      print *, ' '
      print *, '	*** FGMRES ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     fgmres)
      print *, ' '
      print *, '	*** DQGMRES ***'
      call runrc(nrow,rhs,sol,ipar,fpar,wk,xran,a,ja,ia,au,jau,ju,
     +     dqgmres)
      stop
      end
c-----end-of-main
c-----------------------------------------------------------------------


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Magnify an image.  The vertical direction is magnified.  The
C horizontal dimension may be magnified or compressed.
C Input and output images may be byte, halfword, fullword, or real*4.
C Mixed data types (e.g. byte input, halfword output) are permitted.
C
      SUBROUTINE MAGNIFY(SCALE,N,SAMP,WGHT,ib,buf,rbuf,obuf)
      IMPLICIT NONE
      INTEGER*4 N,IB,SAMP(N)
	REAL*4 BUF(*),OBUF(N)
      REAL*4 SCALE,RBUF(N,2),WGHT(N)

      COMMON/CP/IUNIT,ICODE,SLI,SSI,NLI,NSI
      COMMON/CP/OUNIT,OCODE,SLO,SSO,NLO,NSO,NLOUT,NSOUT
      COMMON/CP/ZOOML,ZOOMS,LZOOM,IZOOM,GSCALE,ILO,IHI,LFLAG
      INTEGER*4 IUNIT,ICODE,SLI,SSI,NLI,NSI
      INTEGER*4 OUNIT,OCODE,SLO,SSO,NLO,NSO,NLOUT,NSOUT
      INTEGER*4 LZOOM,IZOOM,ILO,IHI,LFLAG
      REAL*4 ZOOML,ZOOMS,GSCALE

      INTEGER*4 ELI,IND,L
      INTEGER*4 I1,I2,J1,J2,ITEMP,JSAVE
      REAL*4 REC,R,Y0,D,C

      R = 1.0/ZOOML
      REC = SLI - .5
      ELI = SLI + NLI - 1
      I1 = 1
      I2 = 2
      JSAVE = 0
      J2 = 0

      DO 50 L=1,NLO
      Y0 = R*(L-.5) + REC
      J1 = Y0
      J1 = MAX0(J1,SLI)
      J1 = MIN0(J1,ELI-1)
      IF (J1.EQ.JSAVE) GOTO 40	!Skip read (image lines already in memory)
      JSAVE = J1
      ITEMP = I1
      I1 = I2
      I2 = ITEMP
      IF (J1.GT.J2) CALL SREAD(IUNIT,J1,SSI,NSI,NSO,IZOOM,ZOOMS,
     & SAMP,WGHT,ib,buf,rbuf(1,i1))
      J2 = J1 + 1
      CALL SREAD(IUNIT,J2,SSI,NSI,NSO,IZOOM,ZOOMS,
     & SAMP,WGHT,ib,buf,rbuf(1,i2))
   40 D = Y0 - J1		!Compute vertical weights
      C = (1.-D)*SCALE
      D = D*SCALE
      CALL INTRPV(OCODE,NSO,ILO,IHI,C,D,RBUF(1,I1),RBUF(1,I2),
     & obuf(sso))
   50 CALL XVWRIT(OUNIT,OBUF,ind,'LINE',SLO+L-1,'BAND',IB,' ')

      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Compute an output image line by iterpolating between two image
C lines BUF1 and BUF2.
C If OCODE=4, the output line is REAL*4.  Otherwise it is INTEGER*4.
C
      SUBROUTINE INTRPV(OCODE,NSO,ILO,IHI,C,D,BUF1,BUF2,obuf)
      IMPLICIT NONE
      INTEGER*4 OCODE,NSO,ILO,IHI
      REAL*4 C,D,BUF1(NSO),BUF2(NSO),OBUF(NSO)

      INTEGER*4 I,DN

      IF (OCODE.EQ.4) GOTO 50
      DO I=1,NSO
         DN = NINT(BUF1(I)*C + BUF2(I)*D)
         IF (DN.GT.IHI) THEN
            DN = IHI
         ELSE IF (DN.LT.ILO) THEN
            DN = ILO
 	 ENDIF
         OBUF(I) = REAL(DN)
      ENDDO
      RETURN
C
C    ....Here for real*4 output
   50 DO I=1,NSO
         OBUF(I) = BUF1(I)*C + BUF2(I)*D
      ENDDO
      RETURN
      END