module bonn
!Computes the Bonn potential from L. White and F. Sammarruca, "Solution of the Bethe-Goldstone Equation without Partial Wave Decomposition".
!
!References:
!   Ref.[1] = R. Machleidt et al., The Bonn meson-exchange model for the nucleon-nucleon interation.
!   Ref.[2] = R. Machleidt, Adv. Nucl. Phys. 19, 1989, "The Meson Theory of Nuclear Forces and Nuclear Structure".
!   Ref.[3] = R. Machleidt, "Computational Nuclear Physics 2: Nuclear Reactions", Editors: K. Langanke et al.
!	Ref.[4] = L. White and F. Sammarruca, "Solution of the Bethe-Goldstone Equation without Partial Wave Decomposition".
!   In the comments below alpha = pion,eta,sigma,delta,omega,rho.

use inputs
implicit none

    !Stores the Bonn potential parameters. The parameters came from Ref.[2].

   !___________Bonn B_________________

    !m = Free space nucleon mass in MeV
	real(8), parameter, public :: m = 938.926d0

    !Mass of pi,eta,sigma,delta,omega,rho mesons in MeV.
	real(8), parameter, private :: m_pi = 138.03d0
	real(8), parameter, private :: m_eta = 548.8d0
	real(8), parameter, private :: m_sigma = 550.0d0
	real(8), parameter, private :: m_delta = 983.0d0
	real(8), parameter, private :: m_omega = 782.6d0
	real(8), parameter, private :: m_rho = 769.0d0

    !Coupling constant of pi,eta,sigma,delta,omega,rho in MeV.
    !The numbers below (x) are:  x = ( (g_alpha)**2 )/(4*pi) and g_alpha appears in Ref.[1] p.75-76.
	real(8), parameter, private :: g_pi = 14.6d0
	real(8), parameter, private :: g_eta = 5.0d0
	real(8), parameter, private :: g_sigma = 8.0769d0
	real(8), parameter, private :: g_delta = 3.1155d0
	real(8), parameter, private :: g_omega = 20.0d0
	real(8), parameter, private :: g_rho = 0.95d0

    !Value for f_rho/g_rho and f_omega/g_omega.
	real(8), parameter, private :: coupling_ratio_rho = 6.1d0
	real(8), parameter, private :: coupling_ratio_omega = 0.0d0

    !n_alpha appering in the form factor.
	real(8), parameter, private :: n_pi = 1.0d0
	real(8), parameter, private :: n_eta = 1.0d0
	real(8), parameter, private :: n_sigma = 1.0d0
	real(8), parameter, private :: n_delta = 1.0d0
	real(8), parameter, private :: n_omega = 1.0d0
	real(8), parameter, private :: n_rho = 1.0d0

    !lambda_alpha appering in the form factor in MeV.
	real(8), parameter, private :: lambda_pi = 1200.0d0
	real(8), parameter, private :: lambda_eta = 1500.0d0
	real(8), parameter, private :: lambda_sigma = 2000.0d0
	real(8), parameter, private :: lambda_delta = 1500.0d0
	real(8), parameter, private :: lambda_omega = 1500.0d0
	real(8), parameter, private :: lambda_rho = 1300.0d0

    !________________End of Bonn B_____________________

    !pi = Value for the constant pi
    real(8), parameter, public :: pi = 3.1415926535897932385d0

    !i = sqrt(-1)
	complex(8), parameter, public :: i = (0.0d0,1.0d0)

contains

subroutine helicity_elements(thetap,phip,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_innerprod,lambda_sigma_element)
!Computes <lambda_1' lambda_2' | lambda_1 lambda_2> and <lambda_1' lambda_2' | vec{sigma}^(1)*vec{sigma}^(2) |lambda_1 lambda_2>.

implicit none

    !(thetap,phip), (theta,phi) = Angular variables for vec{q},vec{q'}.
    !lambda1p,lambda2p,lambda1,lambda2 = Matrix elements i.e. < | >, < |sigma^(1)*sigma^(2)| >.
    !Note, values for lambda1p,lambda2p,lambda1,lambda2 are  +(-) = 0.5(-0.5) i.e. spin up and down.
	real(8), intent(in) :: thetap,phip,theta,phi
	real(8), intent(in) :: lambda1p,lambda2p,lambda1,lambda2

    !lambda_innerprod = Value for <lambda_1' lambda_2'|lambda_1 lambda_2>.
    !lambda_sigma_element = Value for <lambda_1' lambda_2'|vec{sigma}^(1)*vec{sigma}^(2)|lambda_1 lambda_2>.
	complex(8), intent(out) :: lambda_innerprod,lambda_sigma_element

    !lambda = Array contaning [lambda_1',lambda_2',lambda_1,lambda_2]
	real(8), dimension(4) :: lambda

    lambda = (/lambda1p,lambda2p,lambda1,lambda2/)

	if ( compare(lambda,(/0.5d0,0.5d0,0.5d0,0.5d0/)) == 1 .or. compare(lambda,(/-0.5d0,-0.5d0,-0.5d0,-0.5d0/)) == 1) then
    !<++|++>

		lambda_innerprod = 0.5d0*( 1.0d0 + dcos(thetap)*dcos(theta) + dsin(thetap)*dsin(theta)*dcos(phip - phi) )
		lambda_sigma_element = lambda_innerprod - 2.0d0

	elseif ( compare(lambda,(/0.5d0,0.5d0,0.5d0,-0.5d0/)) == 1 .or. compare(lambda,(/0.5d0,0.5d0,-0.5d0,0.5d0/)) == 1&
    &.or. compare(lambda,(/-0.5d0,-0.5d0,0.5d0,-0.5d0/)) == 1 .or. compare(lambda,(/-0.5d0,-0.5d0,-0.5d0,0.5d0/)) == 1 ) then
    !<++|+->

		lambda_innerprod = 0.5d0*( dcos(thetap)*dsin(theta) - dsin(thetap)*dcos(theta)*dcos(phip - phi) ) -&
							&0.5d0*dsin(thetap)*i*dsin(phip - phi)

		lambda_sigma_element = lambda_innerprod

		if ( compare(lambda,(/0.5d0,0.5d0,-0.5d0,0.5d0/)) == 1 .or. compare(lambda,(/-0.5d0,-0.5d0,-0.5d0,0.5d0/)) == 1 ) then

			lambda_innerprod = dcmplx( -real(lambda_innerprod),aimag(lambda_innerprod) )
			lambda_sigma_element = dcmplx( -real(lambda_sigma_element),aimag(lambda_sigma_element) )

		endif

	elseif ( compare(lambda,(/0.5d0,0.5d0,-0.5d0,-0.5d0/)) == 1 .or. compare(lambda,(/-0.5d0,-0.5d0,0.5d0,0.5d0/)) == 1 ) then
    !<++|-->

		lambda_innerprod = 0.5d0*( -1.0d0 + dcos(thetap)*dcos(theta) + dsin(thetap)*dsin(theta)*dcos(phip - phi) )
		lambda_sigma_element = lambda_innerprod + 2.0d0

	elseif ( compare(lambda,(/0.5d0,-0.5d0,0.5d0,0.5d0/)) == 1 .or. compare(lambda,(/0.5d0,-0.5d0,-0.5d0,-0.5d0/)) == 1&
    &.or. compare(lambda,(/-0.5d0,0.5d0,-0.5d0,-0.5d0/)) == 1 .or. compare(lambda,(/-0.5d0,0.5d0,0.5d0,0.5d0/)) == 1 ) then
    !<+-|++>

		lambda_innerprod = 0.5d0*( dsin(thetap)*dcos(theta) - dsin(theta)*dcos(thetap)*dcos(phip - phi) ) -&
							&0.5d0*dsin(theta)*i*dsin(phip - phi)

		lambda_sigma_element = lambda_innerprod

		if ( compare(lambda,(/-0.5d0,0.5d0,-0.5d0,-0.5d0/)) == 1 .or. compare(lambda,(/-0.5d0,0.5d0,0.5d0,0.5d0/)) == 1 ) then

			lambda_innerprod = dcmplx( -real(lambda_innerprod),aimag(lambda_innerprod) )
			lambda_sigma_element = dcmplx( -real(lambda_sigma_element),aimag(lambda_sigma_element) )

		endif

	elseif ( compare(lambda,(/0.5d0,-0.5d0,0.5d0,-0.5d0/)) == 1 .or. compare(lambda,(/-0.5d0,0.5d0,-0.5d0,0.5d0/)) == 1 ) then
    !<+-|+->

		lambda_innerprod = 0.5d0*(  dsin(thetap)*dsin(theta) + ( 1.0d0 + dcos(thetap)*dcos(theta) )*dcos(phip - phi)  ) +&
							&0.5d0*i*( dcos(thetap) + dcos(theta) )*dsin(phip - phi)

		lambda_sigma_element = lambda_innerprod

		if ( compare(lambda,(/-0.5d0,0.5d0,-0.5d0,0.5d0/)) == 1 ) then

			lambda_innerprod = dcmplx( real(lambda_innerprod),-aimag(lambda_innerprod) )
			lambda_sigma_element = dcmplx( real(lambda_sigma_element),-aimag(lambda_sigma_element) )

		endif

	elseif ( compare(lambda,(/0.5d0,-0.5d0,-0.5d0,0.5d0/)) == 1 .or. compare(lambda,(/-0.5d0,0.5d0,0.5d0,-0.5d0/)) == 1 ) then
    !<+-|-+>

		lambda_innerprod = 0.5d0*(  -dsin(thetap)*dsin(theta) + ( 1.0d0 - dcos(thetap)*dcos(theta) )*dcos(phip - phi)  ) +&
							&0.5d0*i*( dcos(thetap) - dcos(theta) )*dsin(phip - phi)

		lambda_sigma_element = lambda_innerprod

		if ( compare(lambda,(/-0.5d0,0.5d0,0.5d0,-0.5d0/)) == 1 ) then

			lambda_innerprod = dcmplx( real(lambda_innerprod),-aimag(lambda_innerprod) )
			lambda_sigma_element = dcmplx( real(lambda_sigma_element),-aimag(lambda_sigma_element) )

		endif

	endif

end subroutine

integer function compare(A,B)
!Check to see if array A = array B.
!If array A = array B then it outputs 1. Otherwise it outputs 0.

implicit none

    !A,B = array to compare
	real(8), dimension(4), intent(in) :: A,B

    !c1,x = Counters
	integer :: c1,x

	x = 0
	do c1 = 1,4

		if ( A(c1) == B(c1) ) then

			x = x + 1

		endif

	enddo

	if ( x == 4 ) then

		compare = 1

	else

		compare = 0

	endif

end function

complex(8) function V_pv(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,&
					&lambda1,lambda2,lambda_alpha,n_alpha,g_alpha,m_alpha,m_1,m_2,m)
!V_pv, used for pi and eta mesons.
!Notes:
!   (f_{ps})**2/( (m_{ps}**2)(2pi)**3 ) --> x/( 8(m*pi)**2 ) Where x is the coupling constant listed as g_alpha. See page 347 Ref.[2].

implicit none

    !(qp,thetap,phip), (q,theta,phi) = vec{q},vec{q'}.
    !lambda1p,lambda2p,lambda1,lambda2 = Value for < | >, < |sigma^(1)*sigma^(2)| >.
    !Note, values for lambda1p,lambda2p,lambda1,lambda2 are 0.5d0 = + and -0.5d0 = - i.e spin up and down.
    !lambda_alpha,n_alpha,g_alpha,m_alpha,m_1,m_2,m = See parameters at begining of code for explanation.
	real(8), intent(in) :: qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_alpha,n_alpha,g_alpha,m_alpha,m_1,m_2,m

    !qp_q_squared = |vec{q'} - vec{q}|**2. It will be used in the form factor.
    !F = Form factor p.74 Ref.[1].
    !E1,E2,E1p,E2p = Relativistic energies (see Ref.[4]).
    !W1,W2,W1p,W2p = E1+M1,etc... (see Ref.[4])
    !lambda_innerprod = <lambda_1' lambda_2' | lambda_1 lambda_2>.
    !lambda_sigma_element = <lambda_1' lambda_2' | vec{sigma}^(1)*vec{sigma}^(2) |lambda_1 lambda_2>.
    !temp1,temp2,..., and beta,L1p,L1,L2p,L2,ans = Temporary variables
	real(8) :: qp_q_squared,F,E1,E2,E1p,E2p,W1,W2,W1p,W2p
	complex(8) :: lambda_innerprod,lambda_sigma_element
	real(8) :: temp1,temp2,temp3,temp4,temp5,beta,L1p,L1,L2p,L2

	qp_q_squared = qp**2.0d0 + q**2.0d0 - 2.0d0*qp*q*( dsin(theta)*dsin(thetap)*dcos(phip-phi) + dcos(thetap)*dcos(theta) )

	F = (   ( (lambda_alpha)**2.0d0 - (m_alpha)**2.0d0 )/(  (lambda_alpha)**2.0d0 + qp_q_squared  )   )**n_alpha
	E1 = dsqrt( m_1**2.0d0 + q**2.0d0 )
	E2 = dsqrt( m_2**2.0d0 + q**2.0d0 )
	E1p = dsqrt( m_1**2.0d0 + qp**2.0d0 )
	E2p = dsqrt( m_2**2.0d0 + qp**2.0d0 )
	W1 = E1 + m_1
	W2 = E2 + m_2
	W1p = E1p + m_1
	W2p = E2p + m_2

	call helicity_elements(thetap,phip,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_innerprod,lambda_sigma_element)

    !Temporary variables
	temp1 = g_alpha/( 8.0d0*((m*pi)**2.0d0) )
	temp2 = dsqrt( (W1p*W2p*W1*W2)/(E1*E1p*E2*E2p) )
	temp3 = (F**2.0d0)/( qp_q_squared + m_alpha**2.0d0 )
	beta = temp1*temp2*temp3
	L1p = (lambda1p*qp)/W1p
	L1 = (lambda1*q)/W1
	L2p = (lambda2p*qp)/W2p
	L2 = (lambda2*q)/W2
	temp4 = E1p - E1
	temp5 = E2p - E2

	V_pv = beta*m_1*m_2&
	&*(  4.0d0*( L1p - L1 )*( L2p - L2 ) + ( (temp4*temp5)/(m_1*m_2) )*( L1p + L1 )*( L2p + L2 )&
	&+ ( (2.0d0*temp4)/m_1 )*( L1p + L1 )*( L2p - L2 ) + ( (2.0d0*temp5)/m_2 )*( L1p - L1 )*( L2p + L2 )  )*lambda_innerprod

end function

complex(8) function V_s(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,&
					&lambda1,lambda2,lambda_alpha,n_alpha,g_alpha,m_alpha,m_1,m_2)
!V_s, used for sigma and delta mesons.
!Notes:
!   (g_{ps})**2/( (2pi)**3 ) --> x/( 2*pi**2 ) Where x is the coupling constant listed as g_alpha.
!
implicit none

    !(qp,thetap,phip),(q,theta,phi) = vec{q},vec{q'}.
    !lambda1p,lambda2p,lambda1,lambda2 = < | >, < |sigma^(1)*sigma^(2)| >.
    !Note, values for lambda1p,lambda2p,lambda1,lambda2 are 0.5d0 = + and -0.5d0 = - i.e spin up and down.
    !lambda_alpha,n_alpha,g_alpha,m_alpha,m_1,m_2 = See parameters at begining of code for explanation.
	real(8), intent(in) :: qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_alpha,n_alpha,g_alpha,m_alpha,m_1,m_2

    !qp_q_squared = |vec{q'} - vec{q}|**2. It will be used in the form factor.
    !F = Form factor p.74 Ref.[1].
    !E1,E2,E1p,E2p = Relativistic energies (see Ref.[4]).
    !W1,W2,W1p,W2p = E1+M1,etc... (see Ref.[4])
    !lambda_innerprod = <lambda_1' lambda_2' | lambda_1 lambda_2>
    !lambda_sigma_element = <lambda_1' lambda_2' | vec{sigma}^(1)*vec{sigma}^(2) |lambda_1 lambda_2>
    !temp1,temp2,..., and beta,L1p,L1,L2p,L2,ans = Temporary variables.
	real(8) :: qp_q_squared,F,E1,E2,E1p,E2p,W1,W2,W1p,W2p
	complex(8) :: lambda_innerprod,lambda_sigma_element
	real(8) :: temp1,temp2,temp3,beta,L1p,L1,L2p,L2

	qp_q_squared = qp**2.0d0 + q**2.0d0 - 2.0d0*qp*q*( dsin(theta)*dsin(thetap)*dcos(phip-phi) + dcos(thetap)*dcos(theta) )

	F = (   ( (lambda_alpha)**2.0d0 - (m_alpha)**2.0d0 )/(  (lambda_alpha)**2.0d0 + qp_q_squared  )   )**n_alpha
	E1 = dsqrt( m_1**2.0d0 + q**2.0d0 )
	E2 = dsqrt( m_2**2.0d0 + q**2.0d0 )
	E1p = dsqrt( m_1**2.0d0 + qp**2.0d0 )
	E2p = dsqrt( m_2**2.0d0 + qp**2.0d0 )
	W1 = E1 + m_1
	W2 = E2 + m_2
	W1p = E1p + m_1
	W2p = E2p + m_2

	call helicity_elements(thetap,phip,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_innerprod,lambda_sigma_element)

    !Temporary variables
	temp1 = -g_alpha/( 2.0d0*(pi**2.0d0) )
	temp2 = dsqrt( (W1p*W2p*W1*W2)/(E1*E1p*E2*E2p) )
	temp3 = (F**2.0d0)/( qp_q_squared + m_alpha**2.0d0 )
	beta = temp1*temp2*temp3
	L1p = (lambda1p*qp)/W1p
	L1 = (lambda1*q)/W1
	L2p = (lambda2p*qp)/W2p
	L2 = (lambda2*q)/W2

	V_s = 0.25d0*beta*( 1.0d0 - 4.0d0*L1p*L1 )*( 1.0d0 - 4.0d0*L2p*L2 )*lambda_innerprod

end function

complex(8) function V_v(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,&
					&lambda1,lambda2,lambda_alpha,n_alpha,g_alpha&
	                &,coupling_ratio_alpha,m_alpha,m_1,m_2,m)
!V_v, used for omega and rho mesons.
!Notes:
!   (g_{ps})**2/( (2pi)**3 ) --> x/( 2*pi**2 ) Where x is the coupling constant listed as g_alpha.
!	For vector boson exchange, the potential is the sum of three terms (V_v = V_vv + V_tt + V_vt).

implicit none

    !(qp,thetap,phip), (q,theta,phi) = vec{q},vec{q'}.
    !lambda1p,lambda2p,lambda1,lambda2 = < | >,< |sigma^(1)*sigma^(2)| >.
    !Note, values for lambda1p,lambda2p,lambda1,lambda2 are 0.5d0 = + and -0.5d0 = - i.e spin up and down.
    !lambda_alpha,n_alpha,g_alpha,coupling_ratio_alpha,m_alpha,m_1,m_2,m = See parameters at the begining of code for explanation.
	real(8), intent(in) :: qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_alpha,n_alpha,g_alpha
	real(8), intent(in) :: coupling_ratio_alpha,m_alpha,m_1,m_2,m

    !qp_dot_q = vec{q'} dot vec{q}.
    !qp_q_squared = |vec{q'} - vec{q}|**2. It will be used in the form factor.
    !F = Form factor p.74 Ref.[1].
    !E1,E2,E1p,E2p = Relativistic energies (see Ref.[4]).
    !W1,W2,W1p,W2p = E1+M1,etc... (see Ref.[4])
    !lambda_innerprod = <lambda_1' lambda_2' | lambda_1 lambda_2>.
    !lambda_sigma_element = <lambda_1' lambda_2' | vec{sigma}^(1)*vec{sigma}^(2) |lambda_1 lambda_2>.
    !temp1,temp2,L1p,L1,L2p,L1 and temp1vv(vt,tt),temp2vv(vt,tt),..., and betavv(vt,tt),V_vv(vt,tt) = Temporary variables.
	real(8) :: qp_dot_q,qp_q_squared,F,E1,E2,E1p,E2p,W1,W2,W1p,W2p,temp1,temp2,L1p,L1,L2p,L2
	complex(8) :: lambda_innerprod,lambda_sigma_element
	real(8) :: temp1vv,betavv
	complex(8):: V_vv
	real(8) :: temp1vt,temp2vt,temp3vt,temp4vt,temp5vt,temp6vt,betavt
	complex(8) :: V_vt
	real(8) :: temp1tt,temp2tt,temp3tt,temp4tt,temp5tt,temp6tt,temp7tt,betatt
	complex(8) :: V_tt

	qp_dot_q = qp*q*( dsin(thetap)*dsin(theta)*dcos(phip-phi) + dcos(thetap)*dcos(theta) )
	qp_q_squared = qp**2.0d0 + q**2.0d0 - 2.0d0*qp_dot_q

	F = (   ( (lambda_alpha)**2.0d0 - (m_alpha)**2.0d0 )/(  (lambda_alpha)**2.0d0 + qp_q_squared  )   )**n_alpha
	E1 = dsqrt( m_1**2.0d0 + q**2.0d0 )
	E2 = dsqrt( m_2**2.0d0 + q**2.0d0 )
	E1p = dsqrt( m_1**2.0d0 + qp**2.0d0 )
	E2p = dsqrt( m_2**2.0d0 + qp**2.0d0 )
	W1 = E1 + m_1
	W2 = E2 + m_2
	W1p = E1p + m_1
	W2p = E2p + m_2

	call helicity_elements(thetap,phip,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_innerprod,lambda_sigma_element)

    !Temporary variables
	temp1 = dsqrt( (W1p*W2p*W1*W2)/(E1*E1p*E2*E2p) )
	temp2 = (F**2.0d0)/( qp_q_squared + m_alpha**2.0d0 )
	L1p = (lambda1p*qp)/W1p
	L1 = (lambda1*q)/W1
	L2p = (lambda2p*qp)/W2p
	L2 = (lambda2*q)/W2

!V_vv

    !Temporary variables
	temp1vv = g_alpha/( 2.0d0*(pi**2.0d0) )
	betavv = 0.25d0*temp1*temp2*temp1vv

	V_vv = betavv*(  ( 1.0d0 + 4.0d0*L1p*L1 )*( 1.0d0 + 4.0d0*L2p*L2 )*lambda_innerprod&
	&- 4.0d0*( L1p + L1 )*( L2p + L2 )*lambda_sigma_element  )

!V_vt

    !Temporary variables
	temp1vt = g_alpha/( 2.0d0*(pi**2.0d0) )
	betavt = temp1*temp2*temp1vt
	temp2vt = ( W1p + W2p + W1 + W2 )/m
	temp3vt = ( E1p + E2p + E1 + E2 - 2.0d0*(m_1 + m_2) )/(2.0d0*m)
	temp4vt = (m_1 + m_2)/m
	temp5vt = ( E1p - E1 )/m
	temp6vt = (E2p - E2)/m

	V_vt = (coupling_ratio_alpha/2.0d0)*betavt*(   (  temp2vt*( 8.0d0*L1p*L1*L2p*L2 ) - temp3vt  )*lambda_innerprod&
	&- (  (2.0d0*temp4vt)*(L1p + L1)*(L2p + L2) + temp5vt*(L1p - L1)*(L2p + L2)&
	&+ temp6vt*(L1p + L1)*(L2p - L2)  )*lambda_sigma_element   )

!V_tt

    !Temporary variables
	temp1tt = g_alpha/( 2.0d0*(pi**2.0d0) )
	betatt = temp1*temp2*temp1tt
	temp2tt = (m_1*m_2)/(m**2.0d0)
    temp3tt = ( E1p + E2p + E1 + E2 )/( 2.0d0*(m**2.0d0) )
	temp4tt = (E1p + E1)*(E2p + E2) - (E1p - E1)**2.0d0 - (E2p - E2)**2.0d0 + qp**2.0d0 + q**2.0d0 + 2.0d0*qp_dot_q
	temp5tt = ( m_1*(E2p - E2) )/(m**2.0d0)
	temp6tt = ( m_2*(E1p - E1) )/(m**2.0d0)
	temp7tt = ( (E1p - E1)*(E2p - E2) )/(m**2)

	V_tt = ( (coupling_ratio_alpha/2.0d0)**2.0d0 )*betatt*(    (   temp2tt*(1.0d0 + 4.0d0*L1p*L1)*(1.0d0 + 4.0d0*L2p*L2)&
	&- temp3tt*( m_1*(1.0d0 + 4.0d0*L1p*L1)*(1.0d0 - 4.0d0*L2p*L2) + m_2*(1.0d0 - 4.0d0*L1p*L1)*(1.0d0 + 4.0d0*L2p*L2) )&
	&+ (1.0d0/(m**2.0d0))*(1.0d0 - 4.0d0*L1p*L1)*(1.0d0 - 4.0d0*L2p*L2)*( 2.0d0*m_1*m_2 + 0.25d0*temp4tt )   )*lambda_innerprod&
	&- (   4.0d0*temp2tt*(L1p + L1)*(L2p + L2) + 2.0d0*temp5tt*(L1p + L1)*(L2p - L2)&
	&+ 2.0d0*temp6tt*(L1p - L1)*(L2p + L2) + temp7tt*(L1p - L1)*(L2p - L2)   )*lambda_sigma_element    )

!V_v

	V_v = V_vv + V_vt + V_tt

end function

complex(8) function V(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,T)
!V_Bonn

implicit none

    !T = Total isospin. T can be 0 or 1.
    !(qp,thetap,phip), (q,theta,phi) = vec{q},vec{q'}.
    !lambda1p,lambda2p,lambda1,lambda2 = < | >,< |sigma^(1)*sigma^(2)| >.
    !Note, values for lambda1p,lambda2p,lambda1,lambda2 are 0.5d0 = + and -0.5d0 = - i.e spin up and down.
	integer, intent(in) :: T
	real(8), intent(in) :: qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2

    !V_pi,V_eta,V_sigma,V_delta,V_omega,V_rho = Different meson contributions to the potential.
    !x = Isospin coefficient. i.e. x = -3 for T = 0 and x = 1 for T = 1.
	complex(8) :: V_pi,V_eta,V_sigma,V_delta,V_omega,V_rho
	real(8) :: x

    !Pi (isovector)
	V_pi = V_pv(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_pi,n_pi,g_pi,m_pi,m_1,m_2,m)

    !Eta (isoscalar)
	V_eta = V_pv(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_eta,n_eta,g_eta,m_eta,m_1,m_2,m)

    !Sigma (isoscalar)
	V_sigma = V_s(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_sigma,n_sigma,g_sigma,m_sigma,m_1,m_2)

    !Delta (isovector)
	V_delta = V_s(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_delta,n_delta,g_delta,m_delta,m_1,m_2)

    !Omega (isoscalar)
	V_omega = V_v(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_omega,n_omega,g_omega&
	&,coupling_ratio_omega,m_omega,m_1,m_2,m)

    !Rho (isovector)
	V_rho = V_v(qp,thetap,phip,q,theta,phi,lambda1p,lambda2p,lambda1,lambda2,lambda_rho,n_rho,g_rho&
	&,coupling_ratio_rho,m_rho,m_1,m_2,m)

    !Isospin coefficient
	if( T == 1 ) then

		x = 1.0d0

	else

		x = -3.0d0

	endif

    !V_Bonn
	V = V_eta + V_sigma + V_omega + x*( V_pi + V_delta + V_rho )

end function

end module


!=============================================================================!
        subroutine rhs(rl, vl)
!
!       Generates the RHS for the compressible 2D-3C, N-S equations
!
!       Written: 5-10-95
!       Revised: 6-19-95
!
!=============================================================================!
        use global
        use local
        implicit none

        integer :: ij
        real :: rl(ndof,nx*ny), vl(ndof,nx*ny)
        real :: fact1, fact2, fact3
!=============================================================================!

        fact1 = one / Re
        fact2 = gamma / ( Pr * Re )
        fact3 = gamma * gamma1 * Ma**2 / Re

!$doacross local(ij)
        do ij = 1, nx*ny

!.... continuity

        rl(1,ij) = rho(ij) * divu(ij) + grho(1,ij) * u1(ij) + &
                   grho(2,ij) * u2(ij)

!.... momentum

        rl(2,ij) = u1(ij) * gu(1,1,ij) + u2(ij) * gu(1,2,ij) +           &
                   rhoinv(ij) * gp(1,ij) -                               &
                   fact1 * ( g1lm(ij) * divu(ij) + lm(ij) * g1divu(ij) + &
                   two * (g1mu(ij) * S(1,1,ij) + g2mu(ij) * S(1,2,ij)  + &
                                   mu(ij) * S1jj(ij) ) ) * rhoinv(ij)

        rl(3,ij) = u1(ij) * gu(2,1,ij) + u2(ij) * gu(2,2,ij) +           &
                   rhoinv(ij) * gp(2,ij) -                               &
                   fact1 * ( g2lm(ij) * divu(ij) + lm(ij) * g2divu(ij) + &
                   two * (g1mu(ij) * S(2,1,ij) + g2mu(ij) * S(2,2,ij) +  &
                                   mu(ij) * S2jj(ij) ) ) * rhoinv(ij)

        rl(4,ij) = u1(ij) * gu(3,1,ij) + u2(ij) * gu(3,2,ij) -           &
                   fact1 * ( two * (g1mu(ij) * S(3,1,ij) +               &
                            g2mu(ij) * S(3,2,ij) + &
                                   mu(ij) * S3jj(ij) ) ) * rhoinv(ij)

!.... temperature

        rl(5,ij) = u1(ij) * gt(1,ij) + u2(ij) * gt(2,ij) +                &
                  gamma1 * t(ij) * divu(ij) - rhoinv(ij) * (              &
                  fact2 * ( g1con(ij) * gt(1,ij) + g2con(ij) * gt(2,ij) + &
                            con(ij) * Lapt(ij) ) +                        &
                  fact3 * ( lm(ij) * divu(ij)**2 + two * mu(ij) * (       &
                        S(1,1,ij)**2 + S(1,2,ij)**2 + S(1,3,ij)**2 +      &
                        S(2,1,ij)**2 + S(2,2,ij)**2 + S(2,3,ij)**2 +      &
                        S(3,1,ij)**2 + S(3,2,ij)**2 ) ) )

        end do

!.... correct the outflow boundaries using Lele & Poinsot BC's

!       call rhs_l(rl,vl)

!.... standard sponge

        if (ispg .gt. 0) then
          if (ispg .eq. 1) then
            call spg_it(rl,vl,spg)
          else if (ispg .eq. 2) then
            !$doacross local(ij)
            do ij = 1, nx*ny
              rl(1,ij) = rl(1,ij) + (spg(ij) + spg2(ij)) * ( vl(1,ij) - one )
              rl(2,ij) = rl(2,ij) + (spg(ij) + spg2(ij)) * ( vl(2,ij) )
              rl(3,ij) = rl(3,ij) + (spg(ij) + spg2(ij)) * ( vl(3,ij) )
              rl(4,ij) = rl(4,ij) + (spg(ij) + spg2(ij)) * ( vl(4,ij) )
              rl(5,ij) = rl(5,ij) + (spg(ij) + spg2(ij)) * ( vl(5,ij) - one )
            end do
          else
            call error('rhs_p$','ispg > 2 is not supported$')
          end if
        end if

!.... explicit smoother

!       if (eps_e .ne. zero) call smoother( rl, vl )

        return
        end


C
C     FFTE: A FAST FOURIER TRANSFORM PACKAGE
C
C     (C) COPYRIGHT SOFTWARE, 2000-2004, 2008-2014, ALL RIGHTS RESERVED
C                BY
C         DAISUKE TAKAHASHI
C         FACULTY OF ENGINEERING, INFORMATION AND SYSTEMS
C         UNIVERSITY OF TSUKUBA
C         1-1-1 TENNODAI, TSUKUBA, IBARAKI 305-8573, JAPAN
C         E-MAIL: daisuke@cs.tsukuba.ac.jp
C
C
C     RADIX-2, 3, 4, 5 AND 8 MULTIPLE FFT ROUTINE
C
C     FORTRAN77 SOURCE PROGRAM
C
C     WRITTEN BY DAISUKE TAKAHASHI
C
      SUBROUTINE MFFT235A(A,B,W,NS,N,IP)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(*),B(*),W(*)
      DIMENSION IP(*)
C
      IF (IP(1) .NE. 1) THEN
        KP4=2-MOD(IP(1)+2,3)
        KP8=(IP(1)-KP4)/3
      ELSE
        KP4=0
        KP8=0
      END IF
C
      KEY=1
      J=1
      L=N
      M=1
      DO 10 K=1,KP8
        L=L/8
        IF (L .GE. 2) THEN
          IF (KEY .GE. 0) THEN
            CALL FFT8B(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT8B(B,A,W(J),NS*M,L)
          END IF
          KEY=-KEY
        ELSE
          IF (KEY .GE. 0) THEN
            CALL FFT8B(A,A,W(J),NS*M,L)
          ELSE
            CALL FFT8B(B,A,W(J),NS*M,L)
          END IF
        END IF
        M=M*8
        J=J+L*7
   10 CONTINUE
      DO 20 K=1,IP(3)
        L=L/5
        IF (L .GE. 2) THEN
          IF (KEY .GE. 0) THEN
            CALL FFT5B(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT5B(B,A,W(J),NS*M,L)
          END IF
          KEY=-KEY
        ELSE
          IF (KEY .GE. 0) THEN
            CALL FFT5B(A,A,W(J),NS*M,L)
          ELSE
            CALL FFT5B(B,A,W(J),NS*M,L)
          END IF
        END IF
        M=M*5
        J=J+L*4
   20 CONTINUE
      DO 30 K=1,KP4
        L=L/4
        IF (L .GE. 2) THEN
          IF (KEY .GE. 0) THEN
            CALL FFT4B(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT4B(B,A,W(J),NS*M,L)
          END IF
          KEY=-KEY
        ELSE
          IF (KEY .GE. 0) THEN
            CALL FFT4B(A,A,W(J),NS*M,L)
          ELSE
            CALL FFT4B(B,A,W(J),NS*M,L)
          END IF
        END IF
        M=M*4
        J=J+L*3
   30 CONTINUE
      DO 40 K=1,IP(2)
        L=L/3
        IF (L .GE. 2) THEN
          IF (KEY .GE. 0) THEN
            CALL FFT3B(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT3B(B,A,W(J),NS*M,L)
          END IF
          KEY=-KEY
        ELSE
          IF (KEY .GE. 0) THEN
            CALL FFT3B(A,A,W(J),NS*M,L)
          ELSE
            CALL FFT3B(B,A,W(J),NS*M,L)
          END IF
        END IF
        M=M*3
        J=J+L*2
   40 CONTINUE
      IF (IP(1) .EQ. 1) THEN
        IF (KEY .GE. 0) THEN
          CALL FFT2(A,A,NS*M)
        ELSE
          CALL FFT2(B,A,NS*M)
        END IF
      END IF
      RETURN
      END
      SUBROUTINE MFFT235B(A,B,W,NS,N,IP)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(*),B(*),W(*)
      DIMENSION IP(*)
C
      IF (IP(1) .NE. 1) THEN
        KP4=2-MOD(IP(1)+2,3)
        KP8=(IP(1)-KP4)/3
      ELSE
        KP4=0
        KP8=0
      END IF
C
      KEY=1
      J=1
      L=N
      M=1
      DO 10 K=1,KP8
        L=L/8
        IF (L .GE. 2) THEN
          IF (KEY .GE. 0) THEN
            CALL FFT8(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT8(B,A,W(J),NS*M,L)
          END IF
          KEY=-KEY
        ELSE
          IF (KEY .GE. 0) THEN
            CALL FFT8(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT8(B,B,W(J),NS*M,L)
          END IF
        END IF
        M=M*8
        J=J+L*7
   10 CONTINUE
      DO 20 K=1,IP(3)
        L=L/5
        IF (L .GE. 2) THEN
          IF (KEY .GE. 0) THEN
            CALL FFT5(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT5(B,A,W(J),NS*M,L)
          END IF
          KEY=-KEY
        ELSE
          IF (KEY .GE. 0) THEN
            CALL FFT5(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT5(B,B,W(J),NS*M,L)
          END IF
        END IF
        M=M*5
        J=J+L*4
   20 CONTINUE
      DO 30 K=1,KP4
        L=L/4
        IF (L .GE. 2) THEN
          IF (KEY .GE. 0) THEN
            CALL FFT4(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT4(B,A,W(J),NS*M,L)
          END IF
          KEY=-KEY
        ELSE
          IF (KEY .GE. 0) THEN
            CALL FFT4(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT4(B,B,W(J),NS*M,L)
          END IF
        END IF
        M=M*4
        J=J+L*3
   30 CONTINUE
      DO 40 K=1,IP(2)
        L=L/3
        IF (L .GE. 2) THEN
          IF (KEY .GE. 0) THEN
            CALL FFT3(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT3(B,A,W(J),NS*M,L)
          END IF
          KEY=-KEY
        ELSE
          IF (KEY .GE. 0) THEN
            CALL FFT3(A,B,W(J),NS*M,L)
          ELSE
            CALL FFT3(B,B,W(J),NS*M,L)
          END IF
        END IF
        M=M*3
        J=J+L*2
   40 CONTINUE
      IF (IP(1) .EQ. 1) THEN
        IF (KEY .GE. 0) THEN
          CALL FFT2(A,B,NS*M)
        ELSE
          CALL FFT2(B,B,NS*M)
        END IF
      END IF
      RETURN
      END
      SUBROUTINE ZTRANS(A,B,NX,NY)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(*),B(*)
      DIMENSION LNX(3),LNY(3)
C
      CALL FACTOR(NX,LNX)
      CALL FACTOR(NY,LNY)
C
      IF (NX .EQ. 1 .OR. NY .EQ. 1) THEN
!DIR$ VECTOR ALIGNED
        DO 10 I=1,NX*NY
          B(I)=A(I)
   10   CONTINUE
        RETURN
      END IF
C
      IF (LNX(1)+LNY(1) .LE. 1) THEN
        CALL ZTRANSA(A,B,NX,NY)
      ELSE
        CALL ZTRANSB(A,B,NX,NY)
      END IF
      RETURN
      END
      SUBROUTINE ZTRANSA(A,B,NX,NY)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(NX,*),B(NY,*)
C
      DO 20 I=1,NX
!DIR$ VECTOR ALIGNED
        DO 10 J=1,NY
          B(J,I)=A(I,J)
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE ZTRANSB(A,B,NX,NY)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(NX,*),B(NY,*)
C
      IF (NY .GE. NX) THEN
        DO 20 I=0,NX-1
!DIR$ VECTOR ALIGNED
          DO 10 J=1,NX-I
            B(J,I+J)=A(I+J,J)
   10     CONTINUE
   20   CONTINUE
        DO 40 I=1,NY-NX
!DIR$ VECTOR ALIGNED
          DO 30 J=1,NX
            B(I+J,J)=A(J,I+J)
   30     CONTINUE
   40   CONTINUE
        DO 60 I=NY-NX+1,NY-1
!DIR$ VECTOR ALIGNED
          DO 50 J=1,NY-I
            B(I+J,J)=A(J,I+J)
   50     CONTINUE
   60   CONTINUE
      ELSE
        DO 80 I=0,NY-1
!DIR$ VECTOR ALIGNED
          DO 70 J=1,NY-I
            B(I+J,J)=A(J,I+J)
   70     CONTINUE
   80   CONTINUE
        DO 100 I=1,NX-NY
!DIR$ VECTOR ALIGNED
          DO 90 J=1,NY
            B(J,I+J)=A(I+J,J)
   90     CONTINUE
  100   CONTINUE
        DO 120 I=NX-NY+1,NX-1
!DIR$ VECTOR ALIGNED
          DO 110 J=1,NX-I
            B(J,I+J)=A(I+J,J)
  110     CONTINUE
  120   CONTINUE
      END IF
      RETURN
      END
      SUBROUTINE ZTRANS2(A,B,NX,NY,NZ)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(NX,NY,*),B(NY,NX,*)
C
      DO 10 K=1,NZ
        CALL ZTRANS(A(1,1,K),B(1,1,K),NX,NY)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE MZTRANS(A,B,NS,NX,NY)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 A(NS,NX,*),B(NS,NY,*)
C
      IF (NS .EQ. 1) THEN
        CALL ZTRANS(A(1,1,1),B(1,1,1),NX,NY)
      ELSE
        DO 30 I=1,NX
          DO 20 J=1,NY
!DIR$ VECTOR ALIGNED
            DO 10 K=1,NS
              B(K,J,I)=A(K,I,J)
   10       CONTINUE
   20     CONTINUE
   30   CONTINUE
      END IF
      RETURN
      END


module HICubeMod
 implicit none
 private
 public:: InitHICube, projectparticle,EndCube

 real,save :: xsize,ysize,vsize
 integer,save :: nx,ny,nv
 real,save :: dx,dy,dv
 real,save :: centerv
 real,save,dimension(3) :: lookat,xax,yax,direction

 real, allocatable,save :: cube(:,:,:),scratch(:,:,:)

 real,parameter :: maxx=2,maxy=2,maxv=3
 real,parameter :: Pi=3.141592654

 contains

 subroutine InitHICube
  real :: up(3)
  integer :: test

  print*,' image pixel size (WxH), velocity channels?'
  read*,nx,ny,nv
  print*,' image width, velocity range?'
  read*,xsize,vsize
  print*,' look at?'
  read*, lookat
  print*,' direction?'
  read*,direction
  print*,' upvector'
  read*,up
  print*,' system velocity?'
  read*,centerv

  allocate(cube(nx,ny,nv),scratch(nx,ny,nv),STAT=test)
  if(test.NE.0) call cubeError(1)
   cube=0.

  dx=(xsize)/(nx-1)
  dy=dx
  ysize=dx*(ny-1)
  dv=(vsize)/(nv-1)

  print*,dx,dy,dv
  call normalize(direction)
  call outer(xax,direction,up)
  call normalize(xax)
  call outer(yax,xax,direction)
  call normalize(yax)
  print*,xax,yax

 end subroutine

 subroutine endCube

 call writefits

 deallocate(cube,scratch)

 end subroutine

 subroutine cubeError(i)
  integer i

  print*,i
  stop
 end subroutine

 subroutine projectparticle(pos,hsmooth,vel,dopplerwidth,mass)
  real :: pos(3),hsmooth,vel(3),dopplerwidth,mass,offset(3)
  integer i,j,k,isize,jsize,ksize
!  real, allocatable :: pimage(:,:,:)

  isize=2*maxx*hsmooth/dx+1
  jsize=2*maxy*hsmooth/dy+1
  ksize=2*maxv*dopplerwidth/dv+1
  if(isize.le.nx.and.jsize.le.ny.and.ksize.le.nv) then

  call positionp(i,j,k,offset,pos,hsmooth,vel,dopplerwidth)

!  allocate(pimage(isize,jsize,ksize))

  call makepimage(scratch,offset,isize,jsize,ksize,hsmooth,dopplerwidth)

  call addpimage(i,j,k,isize,jsize,ksize,scratch,mass)

  endif

!  deallocate(pimage)

 end subroutine

 subroutine addpimage(i,j,k,isize,jsize,ksize,pimage,mass)
  integer i,j,k,isize,jsize,ksize,n,m,l
  real mass,pimage(isize,jsize,ksize)

!  do n=1,isize
!   do m=1,jsize
!    do l=1,ksize
  do l=1,ksize
   do m=1,jsize
    do n=1,isize
    if((n+i.GE.1.AND.n+i.LE.nx).AND. &
       (m+j.GE.1.AND.m+j.LE.ny).AND. &
       (k+l.GE.1.AND.k+l.LE.nv)) then
       cube(n+i,m+j,l+k)=cube(n+i,m+j,l+k)+pimage(n,m,l)*mass
    endif
    enddo
   enddo
  enddo

 end subroutine

 subroutine makepimage(pimage,offset,isize,jsize,ksize,hsmooth,dw)
  integer :: isize,jsize,ksize
  real :: offset(3),hsmooth,dw,pimage(isize,jsize,ksize)
  real :: r,di,dj,dk,dens,norm,hinv,dwinv
  integer :: i,j,k

  hinv=1/hsmooth
  dwinv=1/dw
  norm=0.
  if(isize.eq.1.or.jsize.eq.1) then
   pimage(1:isize,1:jsize,1:ksize)=0.
   do k=1,ksize
    dk=-maxv*dw-offset(3)+(k-1)*dv
    dens=exp(-(dk*dwinv)**2/2)
    norm=norm+dens
    pimage((isize+1)/2,(jsize+1)/2,k)=dens
   enddo
  else
!  do i=1,isize
!   do j=1,jsize
!    do k=1,ksize
 do k=1,ksize
  do j=1,jsize
    do i=1,isize
      di=-maxx*hsmooth-offset(1)+(i-1)*dx
      dj=-maxy*hsmooth-offset(2)+(j-1)*dy
      dk=-maxv*dw-offset(3)+(k-1)*dv
      r=SQRT(di**2+dj**2)*hinv
      dens=spline(r)*exp(-(dk*dwinv)**2/2)
      norm=norm+dens
      pimage(i,j,k)=dens
    enddo
   enddo
  enddo
  endif

  if(norm.ne.0) then
!  do i=1,isize
!   do j=1,jsize
!    do k=1,ksize
    do k=1,ksize
   do j=1,jsize
  do i=1,isize
      pimage(i,j,k)=pimage(i,j,k)/norm
    enddo
   enddo
  enddo
  endif

 end subroutine

 subroutine positionp(i,j,k,offset,pos,hsmooth,vel,dw)
  integer :: i,j,k
  real :: offset(3),pos(3),hsmooth,vel(3),dw
  real x,y,v

  x=dot_product(xax,pos-lookat)
  y=dot_product(yax,pos-lookat)
  v=dot_product(direction,vel)-centerv

  i=(x-maxx*hsmooth+xsize/2)/dx
  j=(y-maxy*hsmooth+ysize/2)/dy
  k=(v-maxv*dw+vsize/2)/dv

  offset(1)=(x-maxx*hsmooth+xsize/2)-i*dx
  offset(2)=(y-maxy*hsmooth+ysize/2)-j*dy
  offset(3)=(v-maxv*dw+vsize/2)-k*dv

 end subroutine

 function spline(r) result(w)
  real :: r,w
  w=0
  if(r.GT.2) return
  if(r.LT.1) then
   w=1-3/2.*r**2+3/4.*r**3
  else
   w=1/4.*(2-r)**3
  endif
   w=w*10/(7*Pi)
 end function

 subroutine normalize(n)
  real n(3),v
   v=SQRT(n(1)**2+n(2)**2+n(3)**2)
   n(1)=n(1)/v
   n(2)=n(2)/v
   n(3)=n(3)/v
 end subroutine

 subroutine outer(o,v,w)
  real v(3),w(3),o(3)
  o(1)=v(2)*w(3)-w(2)*v(3)
  o(2)=v(3)*w(1)-w(3)*v(1)
  o(3)=v(1)*w(2)-w(1)*v(2)
 end subroutine

 subroutine writefits
      integer status,unit,blocksize,bitpix,naxis,naxes(3)
      integer i,j,k,group,fpixel,nelements
      character filename*80
      logical simple,extend

      status=0

      filename='HICube.fits'

      call deletefile(filename,status)
      call ftgiou(unit,status)

      blocksize=1
      call ftinit(unit,filename,blocksize,status)

      simple=.true.
      bitpix=-64
      naxis=3
      naxes(1)=nx
      naxes(2)=ny
      naxes(3)=nv
      extend=.true.

      call ftphpr(unit,simple,bitpix,naxis,naxes,0,1,extend,status)

      group=1
      fpixel=1
      nelements=naxes(1)*naxes(2)*naxes(3)
      call ftpprd(unit,group,fpixel,nelements,cube,status)

!      call ftpkyj(unit,'EXPOSURE',1500,'Total Exposure Time',status)

      call ftclos(unit, status)
      call ftfiou(unit, status)

      if (status .gt. 0)call printerror(status)
      end subroutine

      subroutine printerror(status)

      integer status
      character errtext*30,errmessage*80

      if (status .le. 0)return
      call ftgerr(status,errtext)
      print *,'FITSIO Error Status =',status,': ',errtext

      call ftgmsg(errmessage)
      do while (errmessage .ne. ' ')
          print *,errmessage
          call ftgmsg(errmessage)
      enddo
      end subroutine

      subroutine deletefile(filename,status)

      integer status,unit,blocksize
      character*(*) filename

      if (status .gt. 0)return

      call ftgiou(unit,status)

      call ftopen(unit,filename,1,blocksize,status)

      if (status .eq. 0)then
          call ftdelt(unit,status)
      else if (status .eq. 103)then
          status=0
          call ftcmsg
      else
          status=0
          call ftcmsg
          call ftdelt(unit,status)
      end if

      call ftfiou(unit, status)
      end subroutine

end module

program makecube
 use HICubeMod
 include 'globals.h'
 real gpos(3),hsm,gvel(3),dw,himass
 integer i,mode
 character*24 filenaam
 call initmem(nbodsmax,nsphmax,ncells)

 CALL set_parameters(0)

 print*,'filenaam?'
 read*,filenaam
 CALL readbods(filenaam)

 call heattabel
 CALL initpars

 IF(periodic) CALL initbc

 CALL initnewstar

 CALL postprocessread

 call InitHICube

 print*,' map mode( 0=HI,1=H2)?'
 read*, mode

if(mode.eq.0) then
 do i=1,nsph
  gpos=pos(i,1:3)
  gvel=vel(i,1:3)*velscale/1.e5
  hsm=hsmooth(i)
  dw=SQRT(kboltz/amu*temperat(i))/1.e5
  himass=unitm_in_msun*mass(i)*max(0.,1-elecfrac(i))*max(0.,1.-h2frac(i))
  if( himass.gt.0) call projectparticle(gpos,hsm,gvel,dw,himass)
 enddo
else
 do i=1,nsph
  gpos=pos(i,1:3)
  gvel=vel(i,1:3)*velscale/1.e5
  hsm=hsmooth(i)
  dw=SQRT(kboltz/amu/2*temperat(i))/1.e5
  himass=unitm_in_msun*mass(i)*max(0.,1-elecfrac(i))*h2frac(i)
  if( himass.gt.0) call projectparticle(gpos,hsm,gvel,dw,himass)
 enddo
endif

 call EndCube

end program


      subroutine calculate_params(mmm,nsynths,size,rank,iteff1,
     $   teffi,loggi,fehi,alphai)

      implicit real*8 (a-h,o-z)

c   These variables are for iterating over the various parameters for the
c   the atmospheric models
      integer iteff1,ilogg1,ifeh1,ialpha1
      real*8 teffarr(34),loggarr(11),feharr(51),alphaarr(21)
      integer iteff,ilogg,ifeh,ialpha
      real*8 teffi,loggi,fehi,alphai
      integer nlogg,nfeh,nalpha

c   Based on the rank and size, determine the number of synthesis per core.
c   These variables loop through the various synthesis accordingly
      integer mmm,nnn,nsynths,size,rank

Cf2py intent(in) mmm,nsynths,size,rank,iteff1,nlogg,nfeh,nalpha
Cf2py intent(out) teffi,loggi,fehi,alphai

c   Set the parameter ranges for the run

      ilogg1=3
      ifeh1=1
      ialpha1=9

      nlogg=1
      nfeh=30
      nalpha=1

c   Define the parameter ranges for effective temperature (K), surface gravity
c   (log cm s^(-2)), metallicity [Fe/H] (dex), and alpha to iron ratio [alpha/Fe](dex)

      data teffarr/3500, 3600, 3700, 3800, 3900,
     $             4000, 4100, 4200, 4300, 4400,
     $             4500, 4600, 4700, 4800, 4900,
     $             5000, 5100, 5200, 5300, 5400,
     $             5500, 5600, 5800, 6000, 6200,
     $             6400, 6600, 6800, 7000, 7200,
     $             7400, 7600, 7800, 8000/

      data loggarr/0.0, 0.5, 1.0, 1.5, 2.0, 2.5,
     $             3.0, 3.5, 4.0, 4.5, 5.0/

      data feharr/-5.0, -4.9, -4.8, -4.7, -4.6,
     $            -4.5, -4.4, -4.3, -4.2, -4.1,
     $            -4.0, -3.9, -3.8, -3.7, -3.6,
     $            -3.5, -3.4, -3.3, -3.2, -3.1,
     $            -3.0, -2.9, -2.8, -2.7, -2.6,
     $            -2.5, -2.4, -2.3, -2.2, -2.1,
     $            -2.0, -1.9, -1.8, -1.7, -1.6,
     $            -1.5, -1.4, -1.3, -1.2, -1.1,
     $            -1.0, -0.9, -0.8, -0.7, -0.6,
     $            -0.5, -0.4, -0.3, -0.2, -0.1, 0.0/

      data alphaarr/-0.8, -0.7, -0.6, -0.5, -0.4, -0.3, -0.2, -0.1, 0.0,
     $       0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0, 1.1, 1.2/

c     Now based on the given loop number, rank, and size, determine which
c     parameters to use for the synthesis on this processor

      nnn=((mmm-1)*size)+rank+1
      if (nnn.le.nsynths) then
         iteff=floor(real(nnn-1)/real(nlogg*nfeh*nalpha))
         ilogg=floor(real(nnn-1-iteff*nlogg*nfeh*nalpha)
     .        /real(nfeh*nalpha))
         ifeh=floor(real(nnn-1-iteff*nlogg*nfeh*nalpha-ilogg
     .        *nfeh*nalpha)/real(nalpha))
         ialpha=nnn-1-iteff*nlogg*nfeh*nalpha-ilogg
     .        *nfeh*nalpha-ifeh*nalpha
         iteff=iteff+iteff1
         ilogg=ilogg+ilogg1
         ifeh=ifeh+ifeh1
         ialpha=ialpha+ialpha1

c         write(*,*) iteff, ilogg, ifeh, ialpha
         teffi=teffarr(iteff)
         loggi=loggarr(ilogg)
         fehi=feharr(ifeh)
         alphai=alphaarr(ialpha)

         return
      endif

      end


Real, public :: Planck = 6.62607015e-36       ! Planck constant
Real, public :: FineStructure = 7.29735256e-3 ! Fine Structure constant


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c
c ... file ivlapes.f
c
c     this file includes documentation and code for
c     subroutine ivlapes
c
c ... files which must be loaded with ivlapes.f
c
c     sphcom.f, hrfft.f, vhaes.f, vhses.f
c
c
c
c     subroutine ivlapes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +mdbc,ndbc,wvhses,lvhses,work,lwork,ierror)
c
c
c     subroutine ivlapes computes a the vector field (v,w) whose vector
c     laplacian is (vlap,wlap).  w and wlap are east longitudinal
c     components of the vectors.  v and vlap are colatitudinal components
c     of the vectors.  br,bi,cr, and ci are the vector harmonic coefficients
c     of (vlap,wlap).  these must be precomputed by vhaes and are input
c     parameters to ivlapes.  (v,w) have the same symmetry or lack of
c     symmetry about the about the equator as (vlap,wlap).  the input
c     parameters ityp,nt,mdbc,ndbc must have the same values used by
c     vhaes to compute br,bi,cr, and ci for (vlap,wlap).
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct longitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   this parameter should have the same value input to subroutine
c            vhaes to compute the coefficients br,bi,cr, and ci for the
c            vector field (vlap,wlap).  ityp is set as follows:
c
c            = 0  no symmetries exist in (vlap,wlap) about the equator. (v,w)
c                 is computed and stored on the entire sphere in the arrays
c                 arrays v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon.
c
c            = 1  no symmetries exist in (vlap,wlap) about the equator. (v,w)
c                 is computed and stored on the entire sphere in the arrays
c                 v(i,j) and w(i,j) for i=1,...,nlat and j=1,...,nlon.  the
c                 vorticity of (vlap,wlap) is zero so the coefficients cr and
c                 ci are zero and are not used.  the vorticity of (v,w) is
c                 also zero.
c
c
c            = 2  no symmetries exist in (vlap,wlap) about the equator. (v,w)
c                 is computed and stored on the entire sphere in the arrays
c                 w(i,j) and v(i,j) for i=1,...,nlat and j=1,...,nlon.  the
c                 divergence of (vlap,wlap) is zero so the coefficients br and
c                 bi are zero and are not used.  the divergence of (v,w) is
c                 also zero.
c
c            = 3  wlap is antisymmetric and vlap is symmetric about the
c                 equator. consequently w is antisymmetric and v is symmetric.
c                 (v,w) is computed and stored on the northern hemisphere
c                 only.  if nlat is odd, storage is in the arrays v(i,j),
c                 w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays v(i,j),w(i,j) for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  wlap is antisymmetric and vlap is symmetric about the
c                 equator. consequently w is antisymmetric and v is symmetric.
c                 (v,w) is computed and stored on the northern hemisphere
c                 only.  if nlat is odd, storage is in the arrays v(i,j),
c                 w(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays v(i,j),w(i,j) for
c                 i=1,...,nlat/2 and j=1,...,nlon.  the vorticity of (vlap,
c                 wlap) is zero so the coefficients cr,ci are zero and
c                 are not used. the vorticity of (v,w) is also zero.
c
c            = 5  wlap is antisymmetric and vlap is symmetric about the
c                 equator. consequently w is antisymmetric and v is symmetric.
c                 (v,w) is computed and stored on the northern hemisphere
c                 only.  if nlat is odd, storage is in the arrays w(i,j),
c                 v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays w(i,j),v(i,j) for
c                 i=1,...,nlat/2 and j=1,...,nlon.  the divergence of (vlap,
c                 wlap) is zero so the coefficients br,bi are zero and
c                 are not used. the divergence of (v,w) is also zero.
c
c
c            = 6  wlap is symmetric and vlap is antisymmetric about the
c                 equator. consequently w is symmetric and v is antisymmetric.
c                 (v,w) is computed and stored on the northern hemisphere
c                 only.  if nlat is odd, storage is in the arrays w(i,j),
c                 v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays w(i,j),v(i,j) for
c                 i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  wlap is symmetric and vlap is antisymmetric about the
c                 equator. consequently w is symmetric and v is antisymmetric.
c                 (v,w) is computed and stored on the northern hemisphere
c                 only.  if nlat is odd, storage is in the arrays w(i,j),
c                 v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays w(i,j),v(i,j) for
c                 i=1,...,nlat/2 and j=1,...,nlon.  the vorticity of (vlap,
c                 wlap) is zero so the coefficients cr,ci are zero and
c                 are not used. the vorticity of (v,w) is also zero.
c
c            = 8  wlap is symmetric and vlap is antisymmetric about the
c                 equator. consequently w is symmetric and v is antisymmetric.
c                 (v,w) is computed and stored on the northern hemisphere
c                 only.  if nlat is odd, storage is in the arrays w(i,j),
c                 v(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if nlat
c                 is even, storage is in the arrays w(i,j),v(i,j) for
c                 i=1,...,nlat/2 and j=1,...,nlon.  the divergence of (vlap,
c                 wlap) is zero so the coefficients br,bi are zero and
c                 are not used. the divergence of (v,w) is also zero.
c
c
c     nt     nt is the number of vector fields (vlap,wlap). some computational
c            efficiency is obtained for multiple fields.  in the program
c            that calls ivlapes, the arrays v,w,br,bi,cr and ci can be
c            three dimensional corresponding to an indexed multiple vector
c            field.  in this case multiple vector synthesis will be performed
c            to compute the (v,w) for each field (vlap,wlap).  the third
c            index is the synthesis index which assumes the values k=1,...,nt.
c            for a single synthesis set nt=1.  the description of the
c            remaining parameters is simplified by assuming that nt=1 or
c            that all arrays are two dimensional.
c
c   idvw     the first dimension of the arrays w and v as it appears in
c            the program that calls ivlapes.  if ityp=0,1, or 2  then idvw
c            must be at least nlat.  if ityp > 2 and nlat is even then idvw
c            must be at least nlat/2. if ityp > 2 and nlat is odd then idvw
c            must be at least (nlat+1)/2.
c
c   jdvw     the second dimension of the arrays w and v as it appears in
c            the program that calls ivlapes. jdvw must be at least nlon.
c
c
c   br,bi    two or three dimensional arrays (see input parameter nt)
c   cr,ci    that contain vector spherical harmonic coefficients of the
c            vector field (vlap,wlap) as computed by subroutine vhaes.
c            br,bi,cr and ci must be computed by vhaes prior to calling
c            ivlapes.  if ityp=1,4, or 7 then cr,ci are not used and can
c            be dummy arguments.  if ityp=2,5, or 8 then br,bi are not
c            used and can be dummy arguments.
c
c    mdbc    the first dimension of the arrays br,bi,cr and ci as it
c            appears in the program that calls ivlapes.  mdbc must be
c            at least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    ndbc    the second dimension of the arrays br,bi,cr and ci as it
c            appears in the program that calls ivlapes. ndbc must be at
c            least nlat.
c
c    wvhses  an array which must be initialized by subroutine vhsesi.
c            once initialized, wvhses
c            can be used repeatedly by ivlapes as long as nlat and nlon
c            remain unchanged.  wvhses must not be altered between calls
c            of ivlapes.
c
c    lvhses  the dimension of the array wvhses as it appears in the
c            program that calls ivlapes.  let
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd.
c
c            let
c
c               lsavmin = (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
c
c            then lvhses must be greater than or equal to lsavmin
c            (see ierror=9 below).
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls ivlapes. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            if ityp .le. 2 then
c
c               (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1)
c
c            or if ityp .gt. 2 then
c
c               (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1)
c
c            will suffice as a length for lwork.
c
c     **************************************************************
c
c     output parameters
c
c
c    v,w     two or three dimensional arrays (see input parameter nt) that
c            contain a vector field whose vector laplacian is (vlap,wlap).
c            w(i,j) is the east longitude and v(i,j) is the colatitudinal
c            component of the vector. v(i,j) and w(i,j) are given on the
c            sphere at the colatitude
c
c                 theta(i) = (i-1)*pi/(nlat-1)
c
c            for i=1,...,nlat and east longitude
c
c                 lambda(j) = (j-1)*2*pi/nlon
c
c            for j=1,...,nlon.
c
c            let cost and sint be the cosine and sine at colatitude theta.
c            let d( )/dlambda  and d( )/dtheta be the first order partial
c            derivatives in longitude and colatitude.  let sf be either v
c            or w.  define:
c
c                 del2s(sf) = [d(sint*d(sf)/dtheta)/dtheta +
c                               2            2
c                              d (sf)/dlambda /sint]/sint
c
c            then the vector laplacian of (v,w) in (vlap,wlap) satisfies
c
c                 vlap = del2s(v) + (2*cost*dw/dlambda - v)/sint**2
c
c            and
c
c                 wlap = del2s(w) - (2*cost*dv/dlambda + w)/sint**2
c
c
c  ierror    a parameter which flags errors in input parameters as follows:
c
c            = 0  no errors detected
c
c            = 1  error in the specification of nlat
c
c            = 2  error in the specification of nlon
c
c            = 3  error in the specification of ityp
c
c            = 4  error in the specification of nt
c
c            = 5  error in the specification of idvw
c
c            = 6  error in the specification of jdvw
c
c            = 7  error in the specification of mdbc
c
c            = 8  error in the specification of ndbc
c
c            = 9  error in the specification of lvhses
c
c            = 10 error in the specification of lwork
c
c
c **********************************************************************
c
c     end of documentation for ivlapes
c
c **********************************************************************
c
      subroutine ivlapes(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
     +mdbc,ndbc,wvhses,lvhses,work,lwork,ierror)
      dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt)
      dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt)
      dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt)
      dimension wvhses(lvhses),work(lwork)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      if(ityp.lt.0 .or. ityp.gt.8) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((ityp.le.2 .and. idvw.lt.nlat) .or.
     1   (ityp.gt.2 .and. idvw.lt.imid)) return
      ierror = 6
      if(jdvw .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+1)/2)
      if(mdbc .lt. mmax) return
      ierror = 8
      if(ndbc .lt. nlat) return
      ierror = 9
c
c     set minimum and verify saved workspace length
c
      idz = (mmax*(nlat+nlat-mmax+1))/2
      lzimn = idz*imid
      lsavmin = lzimn+lzimn+nlon+15
      if (lvhses .lt. lsavmin) return
c
c     set minimum and verify unsaved work space length
c
      mn = mmax*nlat*nt
      l2 = (nlat+1)/2
      l1 = min0(nlat,(nlon+1)/2)
      if (ityp .le. 2) then
	lwkmin = (2*nt+1)*nlat*nlon + nlat*(4*nt*l1+1)
      else
	lwkmin = (2*nt+1)*l2*nlon + nlat*(4*nt*l1+1)
      end if
      if (lwork .lt. lwkmin) return
      ierror = 0
c
c     set work space pointers for vector laplacian coefficients
c
      if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then
      ibr = 1
      ibi = ibr+mn
      icr = ibi+mn
      ici = icr+mn
      else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then
      ibr = 1
      ibi = ibr+mn
      icr = ibi+mn
      ici = icr
      else
      ibr = 1
      ibi = 1
      icr = ibi+mn
      ici = icr+mn
      end if
      ifn = ici + mn
      iwk = ifn + nlat
      if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then
      liwk = lwork-4*mn-nlat
      else
      liwk = lwork-2*mn-nlat
      end if
      call ivlapes1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,work(ibr),
     +work(ibi),work(icr),work(ici),mmax,work(ifn),mdbc,ndbc,br,bi,
     +cr,ci,wvhses,lvhses,work(iwk),liwk,ierror)
      return
      end

      subroutine ivlapes1(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw,
     +bivw,crvw,civw,mmax,fnn,mdbc,ndbc,br,bi,cr,ci,wsave,lsave,
     +wk,lwk,ierror)
      dimension v(idvw,jdvw,nt),w(idvw,jdvw,nt)
      dimension fnn(nlat),brvw(mmax,nlat,nt),bivw(mmax,nlat,nt)
      dimension crvw(mmax,nlat,nt),civw(mmax,nlat,nt)
      dimension br(mdbc,ndbc,nt),bi(mdbc,ndbc,nt)
      dimension cr(mdbc,ndbc,nt),ci(mdbc,ndbc,nt)
      dimension wsave(lsave),wk(lwk)
c
c     preset coefficient multiplyers
c
      do 1 n=2,nlat
      fn = float(n-1)
      fnn(n) = -1.0/(fn*(fn+1.))
    1 continue
c
c     set (u,v) coefficients from br,bi,cr,ci
c
      if (ityp.eq.0 .or. ityp.eq.3 .or. ityp.eq.6) then
c
c     all coefficients needed
c
      do 2 k=1,nt
      do 3 n=1,nlat
      do 4 m=1,mmax
      brvw(m,n,k) = 0.0
      bivw(m,n,k) = 0.0
      crvw(m,n,k) = 0.0
      civw(m,n,k) = 0.0
    4 continue
    3 continue
      do 5 n=2,nlat
      brvw(1,n,k) = fnn(n)*br(1,n,k)
      bivw(1,n,k) = fnn(n)*bi(1,n,k)
      crvw(1,n,k) = fnn(n)*cr(1,n,k)
      civw(1,n,k) = fnn(n)*ci(1,n,k)
    5 continue
      do 6 m=2,mmax
      do 7 n=m,nlat
      brvw(m,n,k) = fnn(n)*br(m,n,k)
      bivw(m,n,k) = fnn(n)*bi(m,n,k)
      crvw(m,n,k) = fnn(n)*cr(m,n,k)
      civw(m,n,k) = fnn(n)*ci(m,n,k)
    7 continue
    6 continue
    2 continue
      else if (ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) then
c
c     vorticity is zero so cr,ci=0 not used
c
      do 12 k=1,nt
      do 13 n=1,nlat
      do 14 m=1,mmax
      brvw(m,n,k) = 0.0
      bivw(m,n,k) = 0.0
   14 continue
   13 continue
      do 15 n=2,nlat
      brvw(1,n,k) = fnn(n)*br(1,n,k)
      bivw(1,n,k) = fnn(n)*bi(1,n,k)
   15 continue
      do 16 m=2,mmax
      do 17 n=m,nlat
      brvw(m,n,k) = fnn(n)*br(m,n,k)
      bivw(m,n,k) = fnn(n)*bi(m,n,k)
   17 continue
   16 continue
   12 continue
      else
c
c     divergence is zero so br,bi=0 not used
c
      do 22 k=1,nt
      do 23 n=1,nlat
      do 24 m=1,mmax
      crvw(m,n,k) = 0.0
      civw(m,n,k) = 0.0
   24 continue
   23 continue
      do 25 n=2,nlat
      crvw(1,n,k) = fnn(n)*cr(1,n,k)
      civw(1,n,k) = fnn(n)*ci(1,n,k)
   25 continue
      do 26 m=2,mmax
      do 27 n=m,nlat
      crvw(m,n,k) = fnn(n)*cr(m,n,k)
      civw(m,n,k) = fnn(n)*ci(m,n,k)
   27 continue
   26 continue
   22 continue
      end if
c
c     sythesize coefs into vector field (v,w)
c
      call vhses(nlat,nlon,ityp,nt,v,w,idvw,jdvw,brvw,bivw,
     +           crvw,civw,mmax,nlat,wsave,lsave,wk,lwk,ierror)
      return
      end


module displacement_mod
	use settings_mod
	use autoDiff_mod
	use array_mod
	use text_mod
	use netCDF_mod
	implicit none
	private

	!=================================!
	!= regions_t Type and Interfaces =!
	!=================================!

	type::regions_t
		type(ad_t),dimension(:,:),allocatable::A,B
		integer,dimension(2)::shift = 0
		integer,dimension(2)::ij
	contains
		procedure::crossCorrelateDirect
		procedure::leastSquares
		procedure::writeVector
	end type

	interface regions_t
		module procedure newRegions
	end interface

	!=============================!
	!= map_t Type and Interfaces =!
	!=============================!

	type::map_t
		type(ad_t),dimension(:,:),allocatable::C
		real(wp),dimension(:),allocatable::dx,dy
	contains
		procedure::dispInt
		procedure::dispGauss
		procedure::writeMap
	end type

	interface map_t
		module procedure newMap
	end interface

	!================================!
	!= fields_t Type and Interfaces =!
	!================================!

	type::fields_t
		type(ad_t),dimension(:,:),allocatable::fx,fy,ft
	contains
		procedure::dispLsq
		procedure::writeFields
	end type

	interface fields_t
		module procedure newFields
	end interface

	!===========!
	!= Exports =!
	!===========!

	public::regions_t
	public::map_t
	public::deIndex

contains

	!=====================!
	!= region_t Routines =!
	!=====================!

	function newRegions(A,B,ij,shift) result(self)
		type(ad_t),dimension(:,:),intent(in)::A,B
		integer,dimension(2),intent(in)::ij
		integer,dimension(2),intent(in),optional::shift
		type(regions_t)::self

		self%A = A
		self%B = B

		self%ij = ij

		if(present(shift)) self%shift = shift
	end function newRegions

	function crossCorrelateDirect(self,F,idx,pass) result(o)
		!! Compute cross correlation between A and B
		!! Mandates that they are the same shape
		class(regions_t),intent(in)::self
		real(wp),intent(in)::F
		integer,intent(in)::idx,pass
		type(ad_t),dimension(2)::o

		type(map_t)::M
		type(ad_t),dimension(:,:),allocatable::A,B
		character(:),allocatable::fn

		A = pixelize(self%A,1)
		B = pixelize(self%B,2)

		M = map_t(A,B,F)

		if(write_map) then
			fn = 'map'
			fn = fn//'-['//intToChar(self%ij(1))//','//intToChar(self%ij(2))//'|'
			fn = fn//''//intToChar(pass)//']'
			fn = fn//'.nc'
			call M%writeMap(fn,idx)
		end if

		o = real(self%shift,wp)+M%dispGauss()
	end function crossCorrelateDirect

	function leastSquares(self,order,idx,pass) result(o)
		class(regions_t),intent(in)::self
		integer,intent(in)::order
		integer,intent(in)::idx,pass
		type(ad_t),dimension(2)::o

		character(:),allocatable::fn
		type(ad_t),dimension(:,:),allocatable::A,B
		type(fields_t)::F

		A = pixelize(self%A,1)
		B = pixelize(self%B,2)

		F = fields_t(A,B,order)

		if(write_map) then
			fn = 'fields'
			fn = fn//'-['//intToChar(self%ij(1))//','//intToChar(self%ij(2))//'|'
			fn = fn//''//intToChar(pass)//']'
			fn = fn//'.nc'
			call F%writeFields(fn,idx)
		end if

		o = real(self%shift,wp)+F%dispLsq()
	end function leastSquares

	subroutine writeVector(self,fn,v,ts)
		class(regions_t),intent(in)::self
		character(*),intent(in)::fn
		type(ad_t),dimension(2)::v
		integer,intent(in)::ts

		character(5),dimension(3+ADS_COUNT)::varNames
		real(wp),dimension(:),allocatable::x,y,z
		real(wp),dimension(:,:,:),allocatable::buf
		integer,dimension(2)::N
		integer::k

		N = max_pass_sizes

		x = linspace(1.0_wp,real(N(1),wp),N(1))
		y = linspace(1.0_wp,real(N(2),wp),N(2))
		z = linspace(1.0_wp,2.0_wp,2)
		allocate( buf(size(x),size(y),size(z)) )

		varNames(  1  ) = 'I'
		varNames( 2:9 ) = 'dI'//ADS_CHS
		varNames(10:11) = ['dudI','dvdI']

		if(ts==1) call writeGrid(fn,varNames,x,y,z)

		! Real value
		buf(:,:,1) = self%A%val()
		buf(:,:,2) = self%B%val()
		call writeStep(fn,real(ts-1,wp),ts,'I    ',buf)

		! Derivatives
		do k=1,ADS_COUNT
			buf(:,:,1) = self%A%der(k)
			buf(:,:,2) = self%B%der(k)
			call writeStep(fn,real(ts-1,wp),ts,varNames(k+1),buf)
		end do
		do k=1,2
			buf(:,:,1) = deIndex(v(k),1)
			buf(:,:,2) = deIndex(v(k),2)
			call writeStep(fn,real(ts-1,wp),ts,varNames(k+9), buf )
		end do

! 		! First Image
! 		call writeStep(fn,0.0_wp,1,varNames(1),self%A%val())
! 		do k=1,ADS_COUNT
! 			call writeStep(fn,0.0_wp,1,varNames(k+1),self%A%der(k))
! 		end do
! 		do k=1,2
! 			call writeStep(fn,0.0_wp,1,varNames(k+9), deIndex(v(k),1) )
! 		end do
!
! 		! Second Image
! 		call writeStep(fn,1.0_wp,2,varNames(1),self%B%val())
! 		do k=1,ADS_COUNT
! 			call writeStep(fn,1.0_wp,2,varNames(k+1),self%B%der(k))
! 		end do
! 		do k=1,2
! 			call writeStep(fn,1.0_wp,2,varNames(k+9), deIndex(v(k),2) )
! 		end do
	end subroutine writeVector

	!==================!
	!= map_t Routines =!
	!==================!

	function newMap(A,B,F) result(self)
		type(ad_t),dimension(:,:),intent(in)::A
		type(ad_t),dimension(:,:),intent(in)::B
		real(wp),intent(in)::F
		type(map_t)::self

		integer::Ail,Aih,Bil,Bih
		integer::Ajl,Ajh,Bjl,Bjh
		integer,dimension(2)::N
		integer::i,j

		N = shape(A)

		allocate(self%C( -nint(F*N(1)):nint(F*N(1)) , -nint(F*N(2)):nint(F*N(2)) ))
		self%dx = linspace(-real(nint(F*N(1)),wp),real(nint(F*N(1)),wp),size(self%C,1))
		self%dy = linspace(-real(nint(F*N(2)),wp),real(nint(F*N(2)),wp),size(self%C,2))

		do i=lbound(self%C,1),ubound(self%C,1)
			Ail = max(1-i,1); Aih = min(N(1)-i,N(1))
			Bil = max(1+i,1); Bih = min(N(1)+i,N(1))
			do j=lbound(self%C,2),ubound(self%C,2)
				Ajl = max(1-j,1); Ajh = min(N(2)-j,N(2))
				Bjl = max(1+j,1); Bjh = min(N(2)+j,N(2))

				self%C(i,j) = sum(A(Ail:Aih,Ajl:Ajh)*B(Bil:Bih,Bjl:Bjh))/real( (Aih-Ail)*(Ajh-Ajl) ,wp)
			end do
		end do
	end function newMap

	subroutine writeMap(self,fn,ts)
		class(map_t),intent(in)::self
		character(*),intent(in)::fn
		integer,intent(in)::ts

		character(5),dimension( 1+ADS_COUNT )::varNames
		integer::k

		varNames( 1 ) = 'I'
		varNames(2:9) = 'dI'//ADS_CHS

		if(ts==1) call writeGrid(fn,varNames,self%dx,self%dy)

		call writeStep(fn,real(ts-1,wp),ts,varNames(1),self%C%val())
		do k=1,ADS_COUNT
			call writeStep(fn,real(ts-1,wp),ts,varNames(k+1),self%C%der(k))
		end do
	end subroutine writeMap

	function dispInt(self) result(o)
		class(map_t),intent(in)::self
		integer,dimension(2)::o

		integer,dimension(2)::Ni,Nj
		real(wp),dimension(:,:),allocatable::W
		integer::i,j

		Ni = [ lbound(self%C,1),ubound(self%C,1) ]
		Nj = [ lbound(self%C,2),ubound(self%C,2) ]
		allocate( W( Ni(1):Ni(2) , Nj(1):Nj(2) ) )

		forall(i=Ni(1):Ni(2),j=Nj(1):Nj(2))
			W(i,j) = self%C(i,j)%val()*(2.0_wp-real(abs(i),wp)/real(Ni(2),wp))*(1.0_wp-real(abs(j),wp)/real(Nj(2),wp))
		end forall

		o = maxloc(W)+[Ni(1),Nj(1)]-1
	end function dispInt

	function dispGauss(self) result(o)
		class(map_t),intent(in)::self
		type(ad_t),dimension(2)::o

		type(ad_t),dimension(-1:1)::h
		type(ad_t),dimension(2)::s
		integer,dimension(2)::N,m
		integer::i

		N = shape(self%C)
		m = nint(real(self%dispInt()))
		forall(i=1:2) m(i) = min(max(m(i),lbound(self%C,i)+1),ubound(self%C,i)-1)

		h = self%C(m(1)-1:m(1)+1,m(2))
		s(1) = 0.5_wp*(log(h(-1))-log(h(1)))/(log(h(-1))-2.0_wp*log(h(0))+log(h(1)))

		h = self%C(m(1),m(2)-1:m(2)+1)
		s(2) = 0.5_wp*(log(h(-1))-log(h(1)))/(log(h(-1))-2.0_wp*log(h(0))+log(h(1)))

		o = real(m,wp)+s
	end function dispGauss

	!=====================!
	!= fields_t Routines =!
	!=====================!

	function newFields(A,B,order) result(self)
		type(ad_t),dimension(:,:),intent(in)::A
		type(ad_t),dimension(:,:),intent(in)::B
		integer,intent(in)::order
		type(fields_t)::self

		self%fx = (grad(A,1,+1,order,1.0_wp)+grad(B,1,-1,order,1.0_wp))/2.0_wp
		self%fy = (grad(A,2,+1,order,1.0_wp)+grad(B,2,-1,order,1.0_wp))/2.0_wp
		self%ft = B-A

	contains

		function grad(f,dir,fb,order,h) result(o)
			type(ad_t),dimension(:,:),intent(in)::f
				!! Field to differentiate
			integer,intent(in)::dir
				!! Direction of derivative
			integer,intent(in)::fb
				!! Forwards or backwards derivative f=+1,b=-1
			integer,intent(in)::order
				!! Derivative order
			real(wp),intent(in)::h
				!! Step size
			type(ad_t),dimension(:,:),allocatable::o
				!! Differentiated field

			real(wp),dimension(-2:2,1:2,-1:1)::C

			integer,dimension(2)::N,d
			type(ad_t),dimension(-2:2)::l
			integer::i,j,k

			C = 0.0_wp
			C(:,1,+1) = [ 0.0_wp, 0.0_wp,-1.0_wp, 1.0_wp, 0.0_wp]
			C(:,2,+1) = [ 0.0_wp, 0.0_wp,-1.5_wp, 2.0_wp,-0.5_wp]
			C(:,1,-1) = [ 0.0_wp,-1.0_wp, 1.0_wp, 0.0_wp, 0.0_wp]
			C(:,2,-1) = [ 0.5_wp,-2.0_wp, 1.5_wp, 0.0_wp, 0.0_wp]

			N = shape(f)
			d = 0
			d(dir) = 1
			allocate(o(N(1),N(2)))
			o = ad_t(0.0_wp,ADN)

			do j=1+2,N(2)-2
				do i=1+2,N(1)-2
					forall(k=-2:2) l(k) = f(i+k*d(1),j+k*d(2))
					o(i,j) = sum(l*C(:,order,fb))/h
				end do
			end do
		end function grad

	end function newFields

	function dispLsq(self) result(o)
		class(fields_t),intent(in)::self
		type(ad_t),dimension(2)::o

		type(ad_t),dimension(2,2)::As,Ai
		type(ad_t),dimension(2)::bs
		type(ad_t)::D

		As(1,1) = sum(self%fx*self%fx)
		As(1,2) = sum(self%fx*self%fy)
		As(2,1) = sum(self%fy*self%fx)
		As(2,2) = sum(self%fy*self%fy)
		bs(1)   = sum(self%fx*self%ft)
		bs(2)   = sum(self%fy*self%ft)

		D = As(1,1)*As(2,2)-As(1,2)*As(2,1)
		Ai(1,1) =  As(2,2)/D
		Ai(1,2) = -As(1,2)/D
		Ai(2,1) = -As(2,1)/D
		Ai(2,2) =  As(1,1)/D

		o = matmul(Ai,-bs)
	end function dispLsq

	subroutine writeFields(self,fn,ts)
		class(fields_t),intent(in)::self
		character(*),intent(in)::fn
		integer,intent(in)::ts

		character(6),dimension( 3*(1+ADS_COUNT) )::varNames
		real(wp),dimension(:),allocatable::x,y
		integer,dimension(2)::N
		integer::k

		N = shape(self%fx)

		x = linspace(1.0_wp,real(N(1),wp),N(1))
		y = linspace(1.0_wp,real(N(2),wp),N(2))

		varNames(  1  ) = 'fx'
		varNames( 2:9 ) = 'dfx'//ADS_CHS
		varNames( 10  ) = 'fy'
		varNames(11:18) = 'dfy'//ADS_CHS
		varNames( 19  ) = 'ft'
		varNames(20:27) = 'dft'//ADS_CHS

		if(ts==1) call writeGrid(fn,varNames,x,y)

		call writeStep(fn,real(ts-1,wp),ts,varNames( 1),self%fx%val())
		call writeStep(fn,real(ts-1,wp),ts,varNames(10),self%fy%val())
		call writeStep(fn,real(ts-1,wp),ts,varNames(19),self%ft%val())

		do k=1,ADS_COUNT
			call writeStep(fn,real(ts-1,wp),ts,varNames(k+1 ),self%fx%der(k))
			call writeStep(fn,real(ts-1,wp),ts,varNames(k+10),self%fy%der(k))
			call writeStep(fn,real(ts-1,wp),ts,varNames(k+19),self%ft%der(k))
		end do
	end subroutine writeFields

	!===================!
	!= Helper Routines =!
	!===================!

	function pixelize(A,f) result(o)
		type(ad_t),dimension(:,:),intent(in)::A
		type(ad_t),dimension(:,:),allocatable::o

		real(wp),dimension(:),allocatable::grad
		integer::f
		integer::i,j

		allocate(o(size(A,1),size(A,2)))
		allocate(grad(ADN))

		do j=1,size(A,2)
			do i=1,size(A,1)
				grad = 0.0_wp
				grad(1:ADS_COUNT) = A(i,j)%grad()
				if(per_pixel) grad( getIndex(i,j,f) ) = 1.0_wp
				o(i,j) = ad_t( A(i,j)%val() , grad )
			end do
		end do
	end function pixelize

	function deIndex(a,f) result(o)
		type(ad_t),intent(in)::a
		integer,intent(in)::f
		real(wp),dimension(:,:),allocatable::o

		integer,dimension(2)::N
		integer::i,j
		real(wp)::m

		N = max_pass_sizes
		allocate( o(N(1),N(2)) )

		do j=1,N(2)
			do i=1,N(1)
				o(i,j) = a%der( getIndex(i,j,f) )
			end do
		end do

		m = sum(o(2:N(1)-1,2:N(2)-1))/real(product(N-2),wp)

		o(  1 ,:) = m
		o(N(1),:) = m
		o(:,  1 ) = m
		o(:,N(1)) = m
	end function deIndex

	function getIndex(i,j,f) result(o)
		integer,intent(in)::i,j,f
		integer::o

		integer::idx

		idx = (f-1)*product(max_pass_sizes)+(j-1)*max_pass_sizes(2)+(i-1)+1

		o = idx+ADS_COUNT
	end function getIndex

end module displacement_mod


      SUBROUTINE DVBES1 (FJ,DJ,SM,RI,NT)
      IMPLICIT REAL*8(A-H,O-Z)
!-----X----X----X----X----X----X----X----X----X----X----X----X----X----X
!-----X CALCULATE THE DERIVATIVES OF THE BESSEL FUNCTIONS.   X----X----X
!-----X   DJ=DFJ/DX WHERE X=SM*RI                                 X----X
!-----X                    D.D.KOELLING                      X----X----X
!-----X----X----X----X----X----X----X----X----X----X----X----X----X----X
      DIMENSION DJ(NT),FJ(NT)
      DATA ZUP/1.0D-5/,ZERO/0.0D0/,THIRD/.3333333333333D0/,ONE/1.0D0/
      X=SM
      IF (X.GT.ZUP)  GO TO 20
      DJ(1)=ZERO
      DJ(2)=THIRD
      DO 10 L=3,NT
  10  DJ(L)=ZERO
      RETURN
  20  Q2=-ONE/X
      Q3=Q2
      DJ(1)=-FJ(2)
      LM=1
      DO 30 L=2,NT
      Q3=Q3+Q2
      DJ(L)=FJ(LM)+Q3*FJ(L)
      LM=LM+1
  30  CONTINUE
      RETURN
      END


PROGRAM array
    IMPLICIT NONE

    ! integer:: i, j

    ! real :: x(10)
    ! PRINT *, (X(I), I = 1, 10)

    ! real:: a(2, 2)
    ! READ *,((A(I, J), i = 1, 2), j = 1, 2)
    ! print *, a(1, 2)

    ! real, Dimension(10):: A(10), B(10), C(10), D(10)
    ! A = 0.0
    ! B = C+D
    ! A(1) = 0.0
    ! B = 0.0
    ! B = cos(A)
    ! PRINT *, (b(I), I = 1, 10)

    ! real, Dimension(3, 3):: A, b, c
    ! open(unit=10,file='input.txt')
    ! read(10, *) a
    ! do i = 1, 3
    !     print *,  A(i, 1), A(i, 2), A(i, 3)
    ! enddo
    ! Close (10)

    ! INTEGER, dimension(2,3):: a
    ! do i = 1, 2
    !     do j = 1, 3
    !         a(i,j) = i+2*j
    !     enddo
    ! enddo
    ! PRINT*, 'Array element =', a(2, 3)
    ! PRINT*, 'Array section =', a(:, 3)
    ! PRINT*, 'Sub-array =', a(1:2,2:3)
    ! PRINT *, 'Whole Array =', a
    ! PRINT*, 'Array Transp”d =',TRANSPOSE(a)
    ! do i = 1, 2
    !     print *,(a(i,j), j=1, 3)
    ! enddo

    ! INTEGER, PARAMETER :: a(6)=(/1,2,3,6,7,8/)
    ! REAL :: b(2)=(/SIN(0.2), COS(0.2)/)
    ! INTEGER :: c(5)=(/ 0, a(1:3), 4/)
    ! REAL :: d(100) = (/ (REAL(i),i=1,100)/)
    ! print *, a
    ! print *, b
    ! print *, c
    ! print *, d

END


C    %W% %G%
      subroutine scal
c
c       THIS SUBROUTINE CALCULATES A SCALE FOR THE PLOT AXIS WHICH
c       RESULT IN AN EASY TO READ SCALE AND ACCOMODATE ALL DATA
c       IT IS CALLED BY CALPLT AND MVPLOT.
C  Revs:
C    Aug/03/92 - DEM
C      Added multiplier of 10 on VRNGE missing in DO 120 loop
C      Added min,max,range values to error messages
c
      include 'tspinc/ovly6.inc'
      include 'tspinc/prt.inc'

C     -     Begin     Begin     Begin     Begin     Begin     Begin

      small=1.0e-5
      trnge=smax-smin
      fuldiv=8.0
      vrnge=0.0001
      if (trnge.eq.0.0) return
C     -  Determine plot range m * 10 ^ nn,  where m = 1,2,4 and
C        nn = -4 .. +4
C     -  Equiv to SM * VRNGE => RNGE,  where VRNGE = 10 ^ nn
      do 120  j = 1, 9
        sm = 1.0
C       -  Fuvr = 8 * 10 ^ nn
        fuvr = fuldiv * vrnge
  100   if (sm .le. 4.000) then
          rnge = sm * fuvr
          if (rnge + small .ge. trnge) go to 160
          sm = sm * 2.0
          go to 100
        endif
        vrnge=vrnge*10.0                                                !dem
  120 call endo
C
      vrnge=vrnge*10.0                                                  !dem
      write (errbuf(1), 137)                                            !dem
  137 format(2x,' SCAL - Automatic scaling problem - range too large.') !dem
      write (errbuf(2), 141) ' Min = ',smin,'  Max = ',smax,            !dem
     +  '  Range = ',trnge                                              !dem
  141 format (2x,a,g11.4,a,g11.4,a,g11.4)                               !dem
      call prterr ('E',2)                                               !dem
      return
c
C     DETERMINE NO OF DEC PLACES
c
  160 scdiv=rnge/fuldiv
      remain=amod(scdiv,10.0)
      if (remain.ne.0.) go to 180
      kxp=-1
      go to 260
  180 do 200 i=1,4
      remain=remain*10.0
      if (remain.ge.1.0) go to 240
  200 continue
C     WRITE (ERRBUF(1),140)
C     CALL PRTERR ('E',1)
      write (errbuf(1), 207)                                            !dem
  207 format(2x,' SCAL - Scaling problem in setting decimal point.')    !dem
      write (errbuf(2), 141) ' Min = ',smin,'  Max = ',smax,            !dem
     +  '  Range = ',trnge                                              !dem
      call prterr ('E',2)                                               !dem
      return
  240 kxp=i
c
C     ESTABLISH SCALE MAX
c
  260 continue
      if (smax.eq.0.0) then
         py=8.0
         fulsy=0.0
         go to 440
      endif
      if (smin.eq.0.0) then
         py=0.0
         fulsy=rnge
         go to 440
      endif
      temp=rnge
  340 do 360 i=1,9
      if (abs(temp-smax).le.small) go to 400
      if (temp-scdiv+small.lt.smax) go to 400
  360 temp=temp-scdiv
C     WRITE (ERRBUF(1),140)
C     CALL PRTERR ('E',1)
      write (errbuf(1),367)
  367 format(2x,' SCAL - Scaling problem in setting plot max.')         !dem
      write (errbuf(2), 141) ' Min = ',smin,'  Max = ',smax,            !dem
     +  '  Range = ',trnge                                              !dem
      call prterr ('E',2)                                               !dem
  400 fulsy=temp
  440 valmin=fulsy-(8.0*scdiv)
c
C     OFF SCALE TEST
c
      if (valmin-small.le.smin) go to 460
c
C     INCREASE RANGE
c
      rnge=rnge*2.0
      if (sm+small.gt.4.0) rnge=rnge*1.25
      go to 160
c
C     DETERM POS Y=0.0
c
  460 pzero=0.0
      py=(pzero-valmin)/scdiv
      return
      end