module metric

use parameters
use constants

implicit none

private

public calculate_contravariant_metric, calculate_covariant_metric, mag_4, calculate_christoffel, &
        calculate_riemann, calculate_spintensor, calculate_FourVelocity, calculate_FourMom, calculate_FourSpin, &
        plasma_fr, plasma_fr_deriv, plasma_ft, plasma_ft_deriv

contains

subroutine mag_4(r,theta,vector,mag)
!Arguments
real(kind=dp), intent(in) :: r,theta
real(kind=dp), intent(in), dimension(4) :: vector
real(kind=dp), intent(out) :: mag
!Other
real(kind=dp), dimension(4,4) :: metric

!WE ASSUME THE VECTOR IS CONTRAVARIANT

call calculate_covariant_metric(r,theta,metric)

mag = metric(1,1)*vector(1)**2.0_dp + metric(2,2)*vector(2)**2.0_dp + metric(3,3)*vector(3)**2.0_dp+metric(4,4)*vector(4)**2.0_dp&
      +2.0_dp*(metric(1,2)*vector(1)*vector(2) + &
               metric(1,3)*vector(1)*vector(3) + &
               metric(1,4)*vector(1)*vector(4) + &
               metric(2,3)*vector(2)*vector(3) + &
               metric(2,4)*vector(2)*vector(4) + &
               metric(3,4)*vector(3)*vector(4)   &
               )

end subroutine mag_4

subroutine calculate_contravariant_metric(r,theta,metric)
!Arguments
real(kind=dp), intent(IN) :: r, theta
real(kind=dp), intent(out), dimension(4,4) :: metric

!Internals
real(kind=dp) :: sigma, delta

sigma = r**2.0_dp + a**2.0_dp*cos(theta)**2
delta = r**2.0_dp - 2.0_dp*r + a**2.0_dp

metric(1,1) = - ((r**2.0_dp + a**2.0_dp) + 2.0_dp*r*a**2.0_dp*sin(theta)**2.0_dp/sigma)/delta
metric(2,2) = delta/sigma
metric(3,3) = 1.0_dp/sigma
metric(4,4) = (1.0_dp-2.0_dp*r/sigma)/(delta*sin(theta)**2.0_dp)

metric(1,4) = -2.0_dp*r*a/(sigma*delta)
metric(4,1) = metric(1,4)

!All other terms are zero
metric(1,2) = 0.0_dp
metric(1,3) = 0.0_dp

metric(2,1) = 0.0_dp
metric(2,3) = 0.0_dp
metric(2,4) = 0.0_dp

metric(3,1) = 0.0_dp
metric(3,2) = 0.0_dp
metric(3,4) = 0.0_dp

metric(4,2) = 0.0_dp
metric(4,3) = 0.0_dp

end subroutine calculate_contravariant_metric

subroutine calculate_covariant_metric(r,theta,metric)
!Arguments
real(kind=dp), intent(IN) :: r, theta
real(kind=dp), intent(out), dimension(4,4) :: metric

!Internals
real(kind=dp) :: sigma, delta

sigma = r**2.0_dp + a**2.0_dp*cos(theta)**2
delta = r**2.0_dp - 2.0_dp*r + a**2.0_dp

metric(1,1) = -(1.0_dp-2.0_dp*r/sigma)
metric(2,2) = sigma/delta
metric(3,3) = sigma
metric(4,4) = (r**2.0_dp + a**2.0_dp + 2.0_dp*r*a**2.0_dp*sin(theta)**2.0_dp/sigma)*sin(theta)**2.0_dp

metric(1,4) = -2.0_dp*r*a*sin(theta)**2.0_dp/sigma
metric(4,1) = metric(1,4)

!All other terms are zero
metric(1,2) = 0.0_dp
metric(1,3) = 0.0_dp

metric(2,1) = 0.0_dp
metric(2,3) = 0.0_dp
metric(2,4) = 0.0_dp

metric(3,1) = 0.0_dp
metric(3,2) = 0.0_dp
metric(3,4) = 0.0_dp

metric(4,2) = 0.0_dp
metric(4,3) = 0.0_dp

end subroutine calculate_covariant_metric

SUBROUTINE calculate_christoffel(r,theta)
!Arguments
real(kind=dp), intent(in) :: r,theta
!Other
real(kind=dp) :: Sg, Dl

Sg = r**2+a**2*cos(theta)**2
Dl = r**2 + a**2 - 2.0_dp*r

G0_00 = 0.0_dp
G0_01 = (r**2+a**2)*(r**2-a**2*cos(theta)**2)/(Sg**2*Dl)
G0_02 = -2.0_dp*r*a**2*sin(theta)*cos(theta)/Sg**2
G0_03 = 0.0_dp
G0_11 = 0.0_dp
G0_12 = 0.0_dp
G0_13 = -a*((3.0_dp*r**2-a**2)*(r**2+a**2)-a**2*(r**2-a**2)*sin(theta)**2)        &
*sin(theta)**2/(Sg**2*Dl)
G0_22 = 0.0_dp
G0_23 = 2.0_dp*r*a**3*sin(theta)**3*cos(theta)/Sg**2
G0_33 = 0.0_dp

G1_00 = Dl*(r**2-a**2*cos(theta)**2)/Sg**3
G1_01 = 0.0_dp
G1_02 = 0.0_dp
G1_03 = -a*Dl*(r**2-a**2*cos(theta)**2)*sin(theta)**2/Sg**3
G1_11 = (-(r**2-a**2)+a**2*sin(theta)**2*(r-1.0_dp))/(Sg*Dl)
G1_12 = -a**2*sin(theta)*cos(theta)/Sg
G1_13 = 0.0_dp
G1_22 = -r*Dl/Sg
G1_23 = 0.0_dp
G1_33 = -(r*(a**2+r**2)**2-a**2*sin(theta)**2*(-a**2*sin(theta)**2*(r-1.0_dp)            &
-1.0_dp*a**2+r*(2.0_dp*(r**2+a**2)+r)))*Dl*sin(theta)**2/Sg**3

G2_00 = -2.0_dp*r*a**2*sin(theta)*cos(theta)/Sg**3
G2_01 = 0.0_dp
G2_02 = 0.0_dp
G2_03 = 2.0_dp*r*a*(r**2+a**2)*sin(theta)*cos(theta)/Sg**3
G2_11 = a**2*sin(theta)*cos(theta)/(Sg*Dl)
G2_12 = r/Sg
G2_13 = 0.0_dp
G2_22 = -a**2*sin(theta)*cos(theta)/Sg
G2_23 = 0.0_dp
G2_33 = -((r**2+a**2)**3-a**2*Dl*(2.0_dp*(r**2+a**2)-a**2*sin(theta)**2)*sin(theta)**2) &
*sin(theta)*cos(theta)/Sg**3

G3_00 = 0.0_dp
G3_01 = a*(r**2-a**2*cos(theta)**2)/(Sg**2*Dl)
G3_02 = -2.0_dp*r*a*(cos(theta)/sin(theta))/Sg**2
G3_03 = 0.0_dp
G3_11 = 0.0_dp
G3_12 = 0.0_dp
G3_13 = (r*Dl*(r**2+a**2)+a**4*(r-1.0_dp)*sin(theta)**4-a**2*(a**2+r**2)*(2.0_dp*r-1.0_dp)*sin(theta)**2) &
/(Sg**2*Dl)
G3_22 = 0.0_dp
G3_23 = ((r**2+a**2)**2+sin(theta)**4*a**4-2.0_dp*a**2*(r**2-1.0_dp*r+a**2)*sin(theta)**2)*(cos(theta)/sin(theta))/Sg**2
G3_33 = 0.0_dp

END SUBROUTINE calculate_christoffel

SUBROUTINE calculate_riemann(r,theta)
!Argument
real(kind = dp) :: r,theta
!Other
real(kind=dp) :: M,Dl,Sg

M = 1.0_dp
Sg = r**2+a**2*cos(theta)**2
Dl = r**2 + a**2 - 2.0_dp*M*r

R_0101 = -M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*(2.0_dp*Dl+a**2*sin(theta)**2)/(Sg**3*Dl)

R_0102 = 3.0_dp*M*a**2*(3.0_dp*r**2-a**2*cos(theta)**2)*sin(theta)*cos(theta)/Sg**3

R_0103 = 0.0_dp

R_0112 = 0.0_dp

R_0113 = -M*r*a*(3.0_dp*(r**2+a**2)-4.0_dp*M*r)*(r**2-3.0_dp*a**2*cos(theta)**2)*sin(theta)**2  &
/(Sg**3*Dl)

R_0123 = M*a*(3.0_dp*r**2-a**2*cos(theta)**2)*(2.0_dp*(r**2+a**2)+a**2*sin(theta)**2)           &
*sin(theta)*cos(theta)/Sg**3

R_0202 = M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*(Dl+2.0_dp*a**2*sin(theta)**2)/Sg**3

R_0203 = 0.0_dp

R_0212 = 0.0_dp

R_0213 = M*a*(3.0_dp*r**2-a**2*cos(theta)**2)*(r**2+a**2+2.0_dp*a**2*sin(theta)**2)             &
*sin(theta)*cos(theta)/Sg**3

R_0223 = M*r*a*(r**2-3.0_dp*a**2*cos(theta)**2)*(3.0_dp*(r**2+a**2)-2.0_dp*M*r)*sin(theta)**2/Sg**3

R_0303 = M*r*Dl*(r**2-3.0_dp*a**2*cos(theta)**2)*sin(theta)**2/Sg**3

R_0312 = -M*a*(3.0_dp*r**2-a**2*cos(theta)**2)*sin(theta)*cos(theta)/Sg**2

R_0313 = 0.0_dp

R_0323 = 0.0_dp

R_1212 = -M*r*(r**2-3.0_dp*a**2*cos(theta)**2)/(Sg*Dl)

R_1213 = 0.0_dp

R_1223 = 0.0_dp

R_1313 = -M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*((r**2+a**2)**2+2.0_dp*a**2*Dl*sin(theta)**2)  &
/(Sg**3*Dl)

R_1323 = 3.0_dp*M*a**2*(r**2+a**2)*(3.0_dp*r**2-a**2*cos(theta)**2)*sin(theta)**3*cos(theta)/Sg**3

R_2323 = M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*(2.0_dp*(r**2+a**2)**2+a**2*Dl*sin(theta)**2)  &
/Sg**3

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

R_0201 = R_0102

R_0301 = R_0103

R_1201 = R_0112

R_1301 = R_0113

R_2301 = R_0123

R_0302 = R_0203

R_1202 = R_0212

R_1302 = R_0213

R_2302 = R_0223

R_1203 = R_0312

R_1303 = R_0313

R_2303 = R_0323

R_1312 = R_1213

R_2312 = R_1223

R_2313 = R_1323

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

R0_001 = 0.0_dp

R0_002 = 0.0_dp

R0_003 = 2.0_dp*sin(theta)**2*M**2*a*r**2*(r**2-3.0_dp*a**2*cos(theta)**2)/Sg**4

R0_012 = -2.0_dp*(3.0_dp*r**2-a**2*cos(theta)**2)*r*M**2*cos(theta)*a**2*sin(theta)/(Sg**3*Dl)

R0_013 = 0.0_dp

R0_023 = 0.0_dp

R0_101 = M*r*(2.0_dp*(r**2+a**2)+a**2*sin(theta)**2)*(r**2-3.0_dp*a**2*cos(theta)**2)/(Sg**3*Dl)

R0_102 = -(3.0_dp*r**2-a**2*cos(theta)**2)*(3.0_dp*(r**2+a**2)-2*M*r)*M*a**2*sin(theta)*cos(theta)/(Sg**3*Dl)

R0_103 = 0.0_dp

R0_112 = 0.0_dp

R0_113 = 3.0_dp*sin(theta)**2*a*M*r*(r**2+a**2)*(r**2-3.0_dp*a**2*cos(theta)**2)/(Sg**3*Dl)

R0_123 = -cos(theta)*sin(theta)*M*a*(3.0_dp*r**2-a**2*cos(theta)**2)*(2.0_dp*(r**2+a**2)**2+a**2*sin(theta)**2*Dl)/(Sg**3*Dl)

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

R0_201 = -(3.0_dp*r**2-a**2*cos(theta)**2)*(3.0_dp*(r**2+a**2)-4*M*r)*a**2*sin(theta)*cos(theta)*M/(Sg**3*Dl)

R0_202 = -M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*(r**2+a**2+2*a**2*sin(theta)**2)/Sg**3

R0_203 = 0.0_dp

R0_212 = 0.0_dp

R0_213 = -(3.0_dp*r**2-a**2*cos(theta)**2)*((a**2+r**2)**2+2.0_dp*a**2*sin(theta)**2*Dl)*M*a*sin(theta)*cos(theta)/(Sg**3*Dl)

R0_223 = -3.0_dp*sin(theta)**2*M*r*a*(a**2+r**2)*(r**2-3.0_dp*a**2*cos(theta)**2)/Sg**3

R0_301 = 0.0_dp

R0_302 = 0.0_dp

R0_303 = -sin(theta)**2*M*r*(r**2+3*a**2*sin(theta)**2-3*a**2)*((a**2+r**2)**2-a**2*sin(theta)**2*Dl)/Sg**4

R0_312 = (3.0_dp*r**2-a**2*cos(theta)**2)*((a**2+r**2)**2-a**2*sin(theta)**2*Dl)*M*a*sin(theta)*cos(theta)/(Sg**3*Dl)

R0_313 = 0.0_dp

R0_323 = 0.0_dp

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

R1_001 = M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*(a**2*sin(theta)**2+2.0_dp*Dl)/Sg**4

R1_002 = -3.0_dp*Dl*M*a**2*(3.0_dp*r**2-a**2*cos(theta)**2)*sin(theta)*cos(theta)/Sg**4

R1_003 = 0.0_dp

R1_012 = 0.0_dp

R1_013 = M*r*a*(3.0_dp*(r**2+a**2)-4.0_dp*M*r)*(r**2-3.0_dp*a**2*cos(theta)**2)*sin(theta)**2/Sg**4

R1_023 = -a*M*(2.0_dp*(r**2+a**2)+a**2*sin(theta)**2)*(3.0_dp*r**2-a**2*cos(theta)**2)*Dl*cos(theta)*sin(theta)/Sg**4

R1_101 = 0.0_dp

R1_102 = 0.0_dp

R1_103 = 0.0_dp

R1_112 = 0.0_dp

R1_113 = 0.0_dp

R1_123 = 0.0_dp

R1_201 = 0.0_dp

R1_202 = 0.0_dp

R1_203 = -cos(theta)*sin(theta)*a*M*(3.0_dp*r**2-a**2*cos(theta)**2)*Dl/Sg**3

R1_212 = -M*r*(r**2-3.0_dp*a**2*cos(theta)**2)/Sg**2

R1_213 = 0.0_dp

R1_223 = 0.0_dp

R1_301 = -sin(theta)**2*M*r*a*(r**2-3.0_dp*a**2*cos(theta)**2)*(3.0_dp*(r**2+a**2)-4.0_dp*M*r)/Sg**4

R1_302 = a*M*(3.0_dp*r**2-a**2*cos(theta)**2)*(r**2+a**2+2.0_dp*a**2*sin(theta)**2)*Dl*cos(theta)*sin(theta)/Sg**4

R1_303 = 0.0_dp

R1_312 = 0.0_dp

R1_313 = -sin(theta)**2*M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*((r**2+a**2)**2+2.0_dp*a**2*Dl*sin(theta)**2)/Sg**4

R1_323 = 3.0_dp*M*a**2*(r**2+a**2)*(3.0_dp*r**2-a**2*cos(theta)**2)*Dl*cos(theta)*sin(theta)**3/Sg**4

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

R2_001 = -3.0_dp*M*a**2*(3.0_dp*r**2-a**2*cos(theta)**2)*sin(theta)*cos(theta)/Sg**4

R2_002 = -M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*(2.0_dp*a**2*sin(theta)**2+Dl)/Sg**4

R2_003 = 0.0_dp

R2_012 = 0.0_dp

R2_013 = -a*M*(3.0_dp*r**2-a**2*cos(theta)**2)*(r**2+a**2+2.0_dp*a**2*sin(theta)**2)*cos(theta)*sin(theta)/Sg**4

R2_023 = -M*r*a*(r**2-3.0_dp*a**2*cos(theta)**2)*(3.0_dp*(r**2+a**2)-2.0_dp*M*r)*sin(theta)**2/Sg**4

R2_101 = 0.0_dp

R2_102 = 0.0_dp

R2_103 = a*M*(3.0_dp*r**2-a**2*cos(theta)**2)*cos(theta)*sin(theta)/Sg**3

R2_112 = M*r*(r**2-3.0_dp*a**2*cos(theta)**2)/(Dl*Sg**2)

R2_113 = 0.0_dp

R2_123 = 0.0_dp

R2_201 = 0.0_dp

R2_202 = 0.0_dp

R2_203 = 0.0_dp

R2_212 = 0.0_dp

R2_213 = 0.0_dp

R2_223 = 0.0_dp

R2_301 = a*M*(2.0_dp*(r**2+a**2)+a**2*sin(theta)**2)*(3.0_dp*r**2-a**2*cos(theta)**2)*cos(theta)*sin(theta)/Sg**4

R2_302 = M*r*a*(r**2-3.0_dp*a**2*cos(theta)**2)*(3.0_dp*(r**2+a**2)-2.0_dp*M*r)*sin(theta)**2/Sg**4

R2_303 = 0.0_dp

R2_312 = 0.0_dp

R2_313 = 3.0_dp*M*a**2*(r**2+a**2)*(3.0_dp*r**2-a**2*cos(theta)**2)*cos(theta)*sin(theta)**3/Sg**4

R2_323 = M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*(2.0_dp*(r**2+a**2)**2+a**2*Dl*sin(theta)**2)*sin(theta)**2/Sg**4

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

R3_001 = 0.0_dp

R3_002 = 0.0_dp

R3_003 = 0.0_dp

R3_012 = -(3.0_dp*r**2-a**2*cos(theta)**2)*(a**2*sin(theta)**2-Dl)*M*a*(cos(theta)/sin(theta))/(Dl*Sg**3)

R3_013 = 0.0_dp

R3_023 = 0.0_dp

R3_101 = 3.0_dp*M*r*a*(r**2-3.0_dp*a**2*cos(theta)**2)/(Dl*Sg**3)

R3_102 = -a*M*(3.0_dp*r**2-a**2*cos(theta)**2)*(2.0_dp*a**2*sin(theta)**2+Dl)*(cos(theta)/sin(theta))/(Dl*Sg**3)

R3_103 = 0.0_dp

R3_112 = 0.0_dp

R3_113 = M*r*(r**2-3.0_dp*a**2*cos(theta)**2)*(r**2+a**2+2.0_dp*a**2*sin(theta)**2)/(Dl*Sg**3)

R3_123 = -(3.0_dp*r**2-a**2*cos(theta)**2)*(3.0_dp*(r**2+a**2)-2.0_dp*M*r)*M*a**2*sin(theta)*cos(theta)/(Dl*Sg**3)

R3_201 = -(3.0_dp*r**2-a**2*cos(theta)**2)*(a**2*sin(theta)**2+2.0_dp*Dl)*M*a*(cos(theta)/sin(theta))/(Dl*Sg**3)

R3_202 = -3.0_dp*M*r*a*(r**2-3.0_dp*a**2*cos(theta)**2)/Sg**3

R3_203 = 0.0_dp

R3_212 = 0.0_dp

R3_213 = -M*a**2*(3*r**2-a**2*cos(theta)**2)*(3.0_dp*(r**2+a**2)-4.0_dp*M*r)*sin(theta)*cos(theta)/(Dl*Sg**3)

R3_223 = -M*r*(2.0_dp*(r**2+a**2)+a**2*sin(theta)**2)*(r**2-3.0_dp*a**2*cos(theta)**2)/Sg**3

R3_301 = 0.0_dp

R3_302 = 0.0_dp

R3_303 = -2.0_dp*M**2*a*r**2*(r**2-3.0_dp*a**2*cos(theta)**2)*sin(theta)**2/Sg**4

R3_312 = 2.0_dp*M**2*r*a**2*(3.0_dp*r**2-a**2*cos(theta)**2)*cos(theta)*sin(theta)/(Dl*Sg**3)

R3_313 = 0.0_dp

R3_323 = 0.0_dp

END SUBROUTINE calculate_riemann

subroutine calculate_spintensor(r, theta, &
                                  SVector, PVector, metric)

!Arguments
real(kind=dp) :: r,theta
!Other
real(kind=dp), dimension(4,4) :: metric !This is actually the contravariant metric
real(kind=dp), dimension(4) ::  SVector, PVector
real(kind=dp) ::  S0,S1,S2,S3,& !spin components
                  P0,P1,P2,P3,& !p components
                  H00,H01,H02,H03,& !metric components
                  H10,H11,H12,H13,&
                  H20,H21,H22,H23,&
                  H30,H31, H32,H33

real(kind=dp) :: Sg, eta0123 !sigma and eta defined

!Read in component values
S0 = SVector(1)
S1 = SVector(2)
S2 = SVector(3)
S3 = SVector(4)

P0 = PVector(1)
P1 = PVector(2)
P2 = PVector(3)
P3 = PVector(4)

H00 = metric(1,1)
H01 = metric(1,2)
H02 = metric(1,3)
H03 = metric(1,4)

H10 = metric(2,1)
H11 = metric(2,2)
H12 = metric(2,3)
H13 = metric(2,4)

H20 = metric(3,1)
H21 = metric(3,2)
H22 = metric(3,3)
H23 = metric(3,4)

H30 = metric(4,1)
H31 = metric(4,2)
H32 = metric(4,3)
H33 = metric(4,4)

!And finally calculate
Sg = r**2+a**2*cos(theta)**2
eta0123 = Sg*sin(theta)

S_01 = eta0123/m0*((H00*H11-H01*H01)*(P2*S3-P3*S2)                    &
+ (H00*H12-H01*H02)*(P3*S1-P1*S3) + (H00*H13-H01*H03)*(P1*S2-P2*S1)   &
+ (H10*H12-H11*H02)*(P0*S3-P3*S0) + (H10*H13-H11*H03)*(P2*S0-P0*S2)   &
+ (H20*H13-H21*H03)*(P0*S1-P1*S0))

S_02 = eta0123/m0*((H00*H21-H02*H01)*(P2*S3-P3*S2)                    &
+ (H00*H22-H02*H02)*(P3*S1-P1*S3) + (H00*H23-H02*H03)*(P1*S2-P2*S1)   &
+ (H10*H22-H12*H02)*(P0*S3-P3*S0) + (H10*H23-H12*H03)*(P2*S0-P0*S2)   &
+ (H20*H23-H22*H03)*(P0*S1-P1*S0))

S_03 = eta0123/m0*((H00*H31-H03*H01)*(P2*S3-P3*S2)                    &
+ (H00*H32-H03*H02)*(P3*S1-P1*S3) + (H00*H33-H03*H03)*(P1*S2-P2*S1)   &
+ (H10*H32-H13*H02)*(P0*S3-P3*S0) + (H10*H33-H13*H03)*(P2*S0-P0*S2)   &
+ (H20*H33-H23*H03)*(P0*S1-P1*S0))

S_12 = eta0123/m0*((H01*H21-H02*H11)*(P2*S3-P3*S2)                    &
+ (H01*H22-H02*H12)*(P3*S1-P1*S3) + (H01*H23-H02*H13)*(P1*S2-P2*S1)   &
+ (H11*H22-H12*H12)*(P0*S3-P3*S0) + (H11*H23-H12*H13)*(P2*S0-P0*S2)   &
+ (H21*H23-H22*H13)*(P0*S1-P1*S0))

S_13 = eta0123/m0*((H01*H31-H03*H11)*(P2*S3-P3*S2)                    &
+ (H01*H32-H03*H12)*(P3*S1-P1*S3) + (H01*H33-H03*H13)*(P1*S2-P2*S1)   &
+ (H11*H32-H13*H12)*(P0*S3-P3*S0) + (H11*H33-H13*H13)*(P2*S0-P0*S2)   &
+ (H21*H33-H23*H13)*(P0*S1-P1*S0))
S_23 = eta0123/m0*((H02*H31-H03*H21)*(P2*S3-P3*S2)                    &
+ (H02*H32-H03*H22)*(P3*S1-P1*S3) + (H02*H33-H03*H23)*(P1*S2-P2*S1)   &
+ (H12*H32-H13*H22)*(P0*S3-P3*S0) + (H12*H33-H13*H23)*(P2*S0-P0*S2)   &
+ (H22*H33-H23*H23)*(P0*S1-P1*S0))

end subroutine calculate_spintensor

subroutine calculate_FourVelocity(PVector, metric, Xprime)

!Arguments
real(kind=dp), dimension(4), intent(in) :: PVector
real(kind=dp), dimension(4,4), intent(in) :: metric
real(kind=dp), dimension(4), intent(out) :: Xprime

!Other
real(kind=dp) :: M, delta, RPS_0, RPS_1, RPS_2, RPS_3
real(kind=dp) :: P0, P1, P2, P3
real(kind=dp) :: Vsq, PV
real(kind=dp) :: g00,g11,g22,g33,g30

g00 = metric(1,1)
g11 = metric(2,2)
g22 = metric(3,3)
g33 = metric(4,4)
g30 = metric(4,1)

!read in relevant data
P0 = PVector(1)
P1 = PVector(2)
P2 = PVector(3)
P3 = PVector(4)

M = 1.0_dp !legacy

delta = 2.0_dp*(m0**2 + lambda*                                                             &
(R_0101*S_01**2+R_0202*S_02**2+R_2323*S_23**2+R_0203*S_02*S_03+R_1301*S_13*S_01             &
+R_1201*S_12*S_01+R_0313*S_03*S_13+R_0312*S_03*S_12+R_0113*S_01*S_13+R_0112*S_01*S_12       &
+R_0301*S_03*S_01+R_1212*S_12**2+R_0201*S_02*S_01+R_0303*S_03**2+R_0302*S_03*S_02           &
+R_1312*S_13*S_12+R_0103*S_01*S_03+R_0102*S_01*S_02+R_1313*S_13**2+R_0123*S_01*S_23         &
+R_1202*S_12*S_02+R_1203*S_12*S_03+R_2313*S_23*S_13+R_2312*S_23*S_12+R_1302*S_13*S_02       &
+R_2303*S_23*S_03+R_2302*S_23*S_02+R_0213*S_02*S_13+R_0212*S_02*S_12+R_2301*S_23*S_01       &
+R_1303*S_13*S_03+R_1213*S_12*S_13+R_1223*S_12*S_23+R_0223*S_02*S_23+R_1323*S_13*S_23       &
+R_0323*S_03*S_23)/4.0_dp)

RPS_0 = S_01**2*R_1301*P3+S_01**2*R_1201*P2+S_02*R_2312*P3*S_12+S_01*R_1203*P2*S_03         &
+S_02*R_2313*P3*S_13-S_01**2*R_0101*P0+S_01*R_1213*P2*S_13-S_02*R_0203*P0*S_03-S_02*R_1201  &
 *P1*S_01-S_03*R_2301*P2*S_01-S_03*R_1301*P1*S_01-S_03*R_0301*P0*S_01-S_02*R_0201*P0*S_01    &
-S_02*R_1203*P1*S_03-S_01*R_0103*P0*S_03-S_03*R_2302*P2*S_02-S_03*R_1302*P1*S_02-S_01       &
 *R_0112*P0*S_12-S_03*R_2312*P2*S_12-S_03*R_1312*P1*S_12-S_03*R_0312*P0*S_12-S_02*R_1212*P1  &
 *S_12-S_02*R_0212*P0*S_12-S_01*R_0102*P0*S_02-S_01*R_0113*P0*S_13-S_03*R_2313*P2*S_13       &
-S_03*R_1313*P1*S_13-S_03*R_0313*P0*S_13-S_02*R_1213*P1*S_13-S_02*R_0213*P0*S_13-S_02       &
 *R_1223*P1*S_23-S_01*R_0123*P0*S_23-S_03*R_2323*P2*S_23-S_03*R_1323*P1*S_23+S_01*R_1302*P3  &
 *S_02+S_01*R_1202*P2*S_02+S_01*R_1313*P3*S_13+S_01*R_1312*P3*S_12+S_01*R_1212*P2*S_12       &
+S_02**2*R_2302*P3-S_03*R_0302*P0*S_02-S_02**2*R_0202*P0-S_02**2*R_1202*P1-S_03**2*R_0303   &
 *P0-S_03**2*R_1303*P1-S_03**2*R_2303*P2+S_02*R_2323*P3*S_23-S_03*R_0323*P0*S_23+S_01*R_1323 &
 *P3*S_23+S_01*R_1223*P2*S_23-S_02*R_0223*P0*S_23+S_02*R_2301*P3*S_01+S_01*R_1303*P3*S_03    &
+S_02*R_2303*P3*S_03

RPS_1 = S_12**2*R_2312*P3+S_12*R_2303*P3*S_03+S_12*R_2313*P3*S_13+S_12*R_2323*P3*S_23       &
-S_01**2*R_0101*P1-S_01**2*R_0201*P2-S_01**2*R_0301*P3-S_12**2*R_0212*P0-S_13**2*R_1313*P1  &
-S_13**2*R_0313*P0-S_01*R_0103*P1*S_03-S_13*R_2301*P2*S_01-S_13*R_0301*P0*S_01-S_13*R_1312  &
 *P1*S_12-S_13*R_0312*P0*S_12-S_13*R_2312*P2*S_12-S_12*R_0201*P0*S_01-S_13*R_2302*P2*S_02    &
-S_13*R_1302*P1*S_02-S_12*R_1203*P1*S_03-S_12*R_0203*P0*S_03-S_12*R_1201*P1*S_01-S_01       &
 *R_0303*P3*S_03-S_01*R_0203*P2*S_03-S_12**2*R_1212*P1-S_01*R_0323*P3*S_23-S_01*R_0223*P2    &
 *S_23-S_01*R_0123*P1*S_23-S_12*R_1223*P1*S_23-S_12*R_0223*P0*S_23-S_13*R_0323*P0*S_23       &
-S_13*R_2323*P2*S_23-S_13*R_1323*P1*S_23+S_12*R_2302*P3*S_02-S_12*R_1202*P1*S_02-S_01       &
 *R_0202*P2*S_02-S_13*R_0302*P0*S_02-S_01*R_0113*P1*S_13-S_01*R_0302*P3*S_02-S_12*R_0202     &
 *P0*S_02-S_01*R_0102*P1*S_02-S_12*R_0213*P0*S_13-S_01*R_0313*P3*S_13-S_01*R_0213*P2*S_13    &
-S_13**2*R_2313*P2-S_01*R_0212*P2*S_12-S_01*R_0112*P1*S_12-S_12*R_1213*P1*S_13-S_01*R_0312  &
 *P3*S_12-S_13*R_1303*P1*S_03-S_13*R_0303*P0*S_03-S_13*R_1301*P1*S_01-S_13*R_2303*P2*S_03    &
+S_12*R_2301*P3*S_01

RPS_2 = -S_12*R_1201*P2*S_01-S_02*R_0301*P3*S_01-S_02*R_0201*P2*S_01-S_23*R_1312*P1*S_12    &
-S_02*R_0101*P1*S_01-S_02*R_0112*P1*S_12-S_02*R_0312*P3*S_12+S_12**2*R_0112*P0-S_12*R_1203  &
 *P2*S_03+S_12*R_0101*P0*S_01-S_23*R_0312*P0*S_12+S_12*R_0103*P0*S_03-S_23*R_2312*P2*S_12    &
+S_12*R_0113*P0*S_13-S_02**2*R_0102*P1-S_12*R_1302*P3*S_02-S_23*R_1303*P1*S_03+S_12*R_0102  &
 *P0*S_02-S_02**2*R_0302*P3-S_23*R_0303*P0*S_03-S_12*R_1313*P3*S_13-S_12**2*R_1312*P3        &
-S_12**2*R_1212*P2-S_23**2*R_0323*P0-S_23*R_2303*P2*S_03-S_23**2*R_1323*P1-S_02**2*R_0202   &
 *P2-S_23*R_0301*P0*S_01-S_12*R_1301*P3*S_01-S_23*R_2301*P2*S_01-S_23*R_1301*P1*S_01-S_02    &
 *R_0212*P2*S_12-S_12*R_1303*P3*S_03-S_02*R_0323*P3*S_23-S_23**2*R_2323*P2-S_02*R_0303*P3    &
 *S_03+S_12*R_0123*P0*S_23-S_12*R_1223*P2*S_23-S_12*R_1213*P2*S_13-S_02*R_0203*P2*S_03-S_23  &
 *R_2302*P2*S_02-S_02*R_0103*P1*S_03-S_23*R_1302*P1*S_02-S_23*R_0302*P0*S_02-S_23*R_2313*P2  &
 *S_13-S_23*R_1313*P1*S_13-S_02*R_0113*P1*S_13-S_02*R_0313*P3*S_13-S_02*R_0213*P2*S_13       &
-S_12*R_1202*P2*S_02-S_12*R_1323*P3*S_23-S_23*R_0313*P0*S_13-S_02*R_0223*P2*S_23-S_02       &
 *R_0123*P1*S_23

RPS_3 = S_23*R_0201*P0*S_01-S_13*R_1301*P3*S_01-S_03*R_0201*P2*S_01-S_03*R_0101*P1*S_01     &
-S_13*R_1201*P2*S_01-S_03*R_0301*P3*S_01-S_23*R_2303*P3*S_03-S_13*R_1303*P3*S_03+S_23       &
 *R_1212*P1*S_12+S_13*R_0103*P0*S_03+S_23*R_0212*P0*S_12-S_23*R_2312*P3*S_12-S_13*R_1203*P2  &
 *S_03+S_13*R_0123*P0*S_23-S_13*R_1323*P3*S_23-S_13*R_1223*P2*S_23-S_03*R_0323*P3*S_23       &
-S_03*R_0123*P1*S_23-S_03*R_0223*P2*S_23+S_23**2*R_0223*P0+S_23**2*R_1223*P1-S_23*R_2302*P3 &
 *S_02+S_13*R_0102*P0*S_02+S_23*R_1202*P1*S_02-S_23**2*R_2323*P3+S_23*R_0202*P0*S_02-S_13    &
 *R_1202*P2*S_02-S_13*R_1302*P3*S_02-S_03*R_0313*P3*S_13+S_13**2*R_0113*P0-S_03*R_0213*P2    &
 *S_13-S_03*R_0102*P1*S_02+S_23*R_0213*P0*S_13-S_13*R_1312*P3*S_12-S_13*R_1212*P2*S_12-S_03  &
 *R_0302*P3*S_02-S_03*R_0202*P2*S_02-S_03*R_0113*P1*S_13+S_23*R_1213*P1*S_13-S_13**2*R_1213  &
 *P2-S_03*R_0212*P2*S_12-S_03*R_0112*P1*S_12-S_23*R_2313*P3*S_13+S_13*R_0112*P0*S_12-S_13**2 &
 *R_1313*P3-S_03*R_0312*P3*S_12+S_23*R_1203*P1*S_03+S_23*R_0203*P0*S_03+S_13*R_0101*P0*S_01  &
+S_23*R_1201*P1*S_01-S_03**2*R_0303*P3-S_23*R_2301*P3*S_01-S_03**2*R_0203*P2-S_03**2*R_0103 &
 *P1

Xprime(1) = - (P0 + lambda*RPS_0/Delta)/m0**2
Xprime(2) = - (P1 + lambda*RPS_1/Delta)/m0**2
Xprime(3) = - (P2 + lambda*RPS_2/Delta)/m0**2
Xprime(4) = - (P3 + lambda*RPS_3/Delta)/m0**2

Vsq = g00*Xprime(1)**2 + g11*Xprime(2)**2 + g22*Xprime(3)**2 + g33*Xprime(4)**2 + 2.0_dp*g30*Xprime(1)*Xprime(4)

PV = -sqrt(-1.0_dp/Vsq)

Xprime = Xprime * PV

end subroutine calculate_FourVelocity

subroutine calculate_FourMom(VVector, PVector, Pprime)
!Arguments
real(kind=dp), intent(in), dimension(4) :: VVector, PVector !Velocity and momentum vector

real(kind=dp), intent(out), dimension(4) :: Pprime

!Other
real (kind=dp) :: V0,V1,V2,V3
real(kind=dp) :: P0,P1,P2,P3
real(kind=dp) :: Pdot1_0, Pdot1_1, Pdot1_2, Pdot1_3
real(kind=dp) :: RS0_0, RS0_1, RS0_2, RS0_3, RS1_0, RS1_1, RS1_2, RS1_3,                     &
                 RS2_0, RS2_1, RS2_2, RS2_3, RS3_0, RS3_1, RS3_2, RS3_3
real(kind=dp) :: Pdot2_0, Pdot2_1, Pdot2_2, Pdot2_3

V0 = VVector(1)
V1 = VVector(2)
V2 = VVector(3)
V3 = VVector(4)

P0 = PVector(1)
P1 = PVector(2)
P2 = PVector(3)
P3 = PVector(4)

Pdot1_0 = -G0_00*V0*P0-G0_01*V0*P1-G0_02*V0*P2-G0_03*V0*P3-G0_01*V1*P0-G0_11*V1*P1-G0_12*V1 &
 *P2-G0_13*V1*P3-G0_02*V2*P0-G0_12*V2*P1-G0_22*V2*P2-G0_23*V2*P3-G0_03*V3*P0-G0_13*V3*P1     &
-G0_23*V3*P2-G0_33*V3*P3

Pdot1_1 = -G1_00*V0*P0-G1_01*V0*P1-G1_02*V0*P2-G1_03*V0*P3-G1_01*V1*P0-G1_11*V1*P1-G1_12*V1 &
 *P2-G1_13*V1*P3-G1_02*V2*P0-G1_12*V2*P1-G1_22*V2*P2-G1_23*V2*P3-G1_03*V3*P0-G1_13*V3*P1     &
-G1_23*V3*P2-G1_33*V3*P3

Pdot1_2 = -G2_00*V0*P0-G2_01*V0*P1-G2_02*V0*P2-G2_03*V0*P3-G2_01*V1*P0-G2_11*V1*P1-G2_12*V1 &
 *P2-G2_13*V1*P3-G2_02*V2*P0-G2_12*V2*P1-G2_22*V2*P2-G2_23*V2*P3-G2_03*V3*P0-G2_13*V3*P1     &
-G2_23*V3*P2-G2_33*V3*P3

Pdot1_3 = -G3_00*V0*P0-G3_01*V0*P1-G3_02*V0*P2-G3_03*V0*P3-G3_01*V1*P0-G3_11*V1*P1-G3_12*V1 &
 *P2-G3_13*V1*P3-G3_02*V2*P0-G3_12*V2*P1-G3_22*V2*P2-G3_23*V2*P3-G3_03*V3*P0-G3_13*V3*P1     &
-G3_23*V3*P2-G3_33*V3*P3

RS0_0 = R0_001*S_01 + R0_002*S_02 + R0_003*S_03 + R0_012*S_12 + R0_013*S_13 + R0_023*S_23
RS0_1 = R0_101*S_01 + R0_102*S_02 + R0_103*S_03 + R0_112*S_12 + R0_113*S_13 + R0_123*S_23
RS0_2 = R0_201*S_01 + R0_202*S_02 + R0_203*S_03 + R0_212*S_12 + R0_213*S_13 + R0_223*S_23
RS0_3 = R0_301*S_01 + R0_302*S_02 + R0_303*S_03 + R0_312*S_12 + R0_313*S_13 + R0_323*S_23

RS1_0 = R1_001*S_01 + R1_002*S_02 + R1_003*S_03 + R1_012*S_12 + R1_013*S_13 + R1_023*S_23
RS1_1 = R1_101*S_01 + R1_102*S_02 + R1_103*S_03 + R1_112*S_12 + R1_113*S_13 + R1_123*S_23
RS1_2 = R1_201*S_01 + R1_202*S_02 + R1_203*S_03 + R1_212*S_12 + R1_213*S_13 + R1_223*S_23
RS1_3 = R1_301*S_01 + R1_302*S_02 + R1_303*S_03 + R1_312*S_12 + R1_313*S_13 + R1_323*S_23

RS2_0 = R2_001*S_01 + R2_002*S_02 + R2_003*S_03 + R2_012*S_12 + R2_013*S_13 + R2_023*S_23
RS2_1 = R2_101*S_01 + R2_102*S_02 + R2_103*S_03 + R2_112*S_12 + R2_113*S_13 + R2_123*S_23
RS2_2 = R2_201*S_01 + R2_202*S_02 + R2_203*S_03 + R2_212*S_12 + R2_213*S_13 + R2_223*S_23
RS2_3 = R2_301*S_01 + R2_302*S_02 + R2_303*S_03 + R2_312*S_12 + R2_313*S_13 + R2_323*S_23

RS3_0 = R3_001*S_01 + R3_002*S_02 + R3_003*S_03 + R3_012*S_12 + R3_013*S_13 + R3_023*S_23
RS3_1 = R3_101*S_01 + R3_102*S_02 + R3_103*S_03 + R3_112*S_12 + R3_113*S_13 + R3_123*S_23
RS3_2 = R3_201*S_01 + R3_202*S_02 + R3_203*S_03 + R3_212*S_12 + R3_213*S_13 + R3_223*S_23
RS3_3 = R3_301*S_01 + R3_302*S_02 + R3_303*S_03 + R3_312*S_12 + R3_313*S_13 + R3_323*S_23

Pdot2_0 = -(RS0_0*V0 + RS0_1*V1 + RS0_2*V2 + RS0_3*V3)

Pdot2_1 = -(RS1_0*V0 + RS1_1*V1 + RS1_2*V2 + RS1_3*V3)

Pdot2_2 = -(RS2_0*V0 + RS2_1*V1 + RS2_2*V2 + RS2_3*V3)

Pdot2_3 = -(RS3_0*V0 + RS3_1*V1 + RS3_2*V2 + RS3_3*V3)

Pprime(1) = Pdot1_0 + lambda*Pdot2_0
Pprime(2) = Pdot1_1 + lambda*Pdot2_1
Pprime(3) = Pdot1_2 + lambda*Pdot2_2
Pprime(4) = Pdot1_3 + lambda*Pdot2_3

end subroutine calculate_FourMom

subroutine calculate_FourSpin(VVector,PVector,SVector, Sprime)
!Arguments
real(kind=dp), dimension(4), intent(in) :: VVector, PVector,SVector
real(kind=dp), dimension(4), intent(out) :: Sprime
!Other
real (kind=dp) :: V0,V1,V2,V3
real(kind=dp) :: S0,S1,S2,S3
real(kind=dp) :: P0,P1,P2,P3
real(kind=dp) :: Scoeff
real(kind=dp) :: Sdot2_0, Sdot2_1, Sdot2_2, Sdot2_3
real(kind=dp) :: Sdot1_0, Sdot1_1, Sdot1_2, Sdot1_3

V0 = VVector(1)
V1 = VVector(2)
V2 = VVector(3)
V3 = VVector(4)

P0 = PVector(1)
P1 = PVector(2)
P2 = PVector(3)
P3 = PVector(4)

S0 = SVector(1)
S1 = SVector(2)
S2 = SVector(3)
S3 = SVector(4)

Scoeff = -(R_0212*S0*V2*S_12-R_1213*S2*V1*S_13-R_1212*S2*V1*S_12-R_1201*S2*V1*S_01-R_2302   &
 *S3*V2*S_02+R_0312*S0*V3*S_12+R_0313*S0*V3*S_13+R_0302*S0*V3*S_02-R_0323*S3*V0*S_23+R_2301  &
 *S2*V3*S_01-R_1303*S3*V1*S_03-R_1202*S2*V1*S_02-R_1203*S2*V1*S_03-R_1223*S2*V1*S_23-R_0301  &
 *S3*V0*S_01-R_0312*S3*V0*S_12-R_1302*S3*V1*S_02-R_1301*S3*V1*S_01+R_2323*S2*V3*S_23-R_0303  &
 *S3*V0*S_03-R_2323*S3*V2*S_23-R_0313*S3*V0*S_13-R_0302*S3*V0*S_02-R_2312*S3*V2*S_12-R_2301  &
 *S3*V2*S_01-R_2313*S3*V2*S_13+R_0113*S0*V1*S_13+R_0213*S0*V2*S_13+R_0223*S0*V2*S_23+R_0112  &
 *S0*V1*S_12-R_0102*S1*V0*S_02+R_0203*S0*V2*S_03-R_0112*S1*V0*S_12-R_0123*S1*V0*S_23+R_0103  &
 *S0*V1*S_03+R_0102*S0*V1*S_02-R_1313*S3*V1*S_13-R_1312*S3*V1*S_12-R_1323*S3*V1*S_23-R_2303  &
 *S3*V2*S_03-R_0113*S1*V0*S_13-R_0101*S1*V0*S_01-R_0103*S1*V0*S_03+R_1223*S1*V2*S_23+R_1213  &
 *S1*V2*S_13+R_1302*S1*V3*S_02+R_0303*S0*V3*S_03+R_0301*S0*V3*S_01+R_0323*S0*V3*S_23-R_0223  &
 *S2*V0*S_23+R_1203*S1*V2*S_03+R_1202*S1*V2*S_02+R_1201*S1*V2*S_01+R_1323*S1*V3*S_23+R_1303  &
 *S1*V3*S_03+R_1312*S1*V3*S_12+R_1212*S1*V2*S_12-R_0213*S2*V0*S_13-R_0201*S2*V0*S_01-R_0202  &
 *S2*V0*S_02-R_0212*S2*V0*S_12+R_1313*S1*V3*S_13+R_1301*S1*V3*S_01-R_0203*S2*V0*S_03+R_2303  &
 *S2*V3*S_03+R_0101*S0*V1*S_01+R_2302*S2*V3*S_02+R_2313*S2*V3*S_13+R_0123*S0*V1*S_23+R_2312  &
 *S2*V3*S_12+R_0202*S0*V2*S_02+R_0201*S0*V2*S_01)/m0**2

Sdot2_0 = Scoeff*P0
Sdot2_1 = Scoeff*P1
Sdot2_2 = Scoeff*P2
Sdot2_3 = Scoeff*P3

Sdot1_0 = -G0_00*V0*S0-G0_01*V0*S1-G0_02*V0*S2-G0_03*V0*S3-G0_01*V1*S0-G0_11*V1*S1-G0_12*V1 &
 *S2-G0_13*V1*S3-G0_02*V2*S0-G0_12*V2*S1-G0_22*V2*S2-G0_23*V2*S3-G0_03*V3*S0-G0_13*V3*S1     &
-G0_23*V3*S2-G0_33*V3*S3

Sdot1_1 = -G1_00*V0*S0-G1_01*V0*S1-G1_02*V0*S2-G1_03*V0*S3-G1_01*V1*S0-G1_11*V1*S1-G1_12*V1 &
 *S2-G1_13*V1*S3-G1_02*V2*S0-G1_12*V2*S1-G1_22*V2*S2-G1_23*V2*S3-G1_03*V3*S0-G1_13*V3*S1     &
-G1_23*V3*S2-G1_33*V3*S3

Sdot1_2 = -G2_00*V0*S0-G2_01*V0*S1-G2_02*V0*S2-G2_03*V0*S3-G2_01*V1*S0-G2_11*V1*S1-G2_12*V1 &
 *S2-G2_13*V1*S3-G2_02*V2*S0-G2_12*V2*S1-G2_22*V2*S2-G2_23*V2*S3-G2_03*V3*S0-G2_13*V3*S1     &
-G2_23*V3*S2-G2_33*V3*S3

Sdot1_3 = -G3_00*V0*S0-G3_01*V0*S1-G3_02*V0*S2-G3_03*V0*S3-G3_01*V1*S0-G3_11*V1*S1-G3_12*V1 &
 *S2-G3_13*V1*S3-G3_02*V2*S0-G3_12*V2*S1-G3_22*V2*S2-G3_23*V2*S3-G3_03*V3*S0-G3_13*V3*S1     &
-G3_23*V3*S2-G3_33*V3*S3

Sprime(1) = Sdot1_0 + lambda*Sdot2_0
Sprime(2) = Sdot1_1 + lambda*Sdot2_1
Sprime(3) = Sdot1_2 + lambda*Sdot2_2
Sprime(4) = Sdot1_3 + lambda*Sdot2_3

end subroutine calculate_FourSpin

!Properties of the plasma
subroutine plasma_fr(r,fr)
real(kind=dp), intent(in) :: r
real(kind=dp), intent(out) :: fr
fr = r**0.90_dp
end subroutine plasma_fr

subroutine plasma_fr_deriv(r,fr)
real(kind=dp), intent(in) :: r
real(kind=dp), intent(out) :: fr
fr = 0.90_dp*r**(-0.10_dp)
end subroutine plasma_fr_deriv

subroutine plasma_ft(r,ft)
real(kind=dp), intent(in) :: r
real(kind=dp), intent(out) :: ft
ft = 0.0_dp
end subroutine plasma_ft

subroutine plasma_ft_deriv(r,ft)
real(kind=dp), intent(in) :: r
real(kind=dp), intent(out) :: ft
ft = 0.0_dp
end subroutine plasma_ft_deriv

end module metric


!    .................................................
        subroutine q2mume(Q2_2t,Q2_1t,Q20t,Q21t,Q22t)
!    .................................................

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

        double precision rnla

        DIMENSION Rnl(HO%nmax,HO%nmax) ! (2,2)
        DIMENSION Q2_2t(HO%NLEV,HO%NLEV)
        DIMENSION Q2_1t(HO%NLEV,HO%NLEV)
        DIMENSION Q20t(HO%NLEV,HO%NLEV)
        DIMENSION Q21t(HO%NLEV,HO%NLEV)
        DIMENSION Q22t(HO%NLEV,HO%NLEV)

        b2=HO%b_osc**2

!initializing

        do ii=1,HO%NLEV
        do jj=1,HO%NLEV
         Q2_2t(jj,ii)=zero
         Q2_1t(jj,ii)=zero
         Q20t(jj,ii)=zero
         Q21t(jj,ii)=zero
         Q22t(jj,ii)=zero
        end do
        end do

!        tnljm%t(kk) = mtisos(kk)
!          tnljm%n(kk) = nlindex(kk)
!          tnljm%l(kk) = lang(kk)
!          tnljm%twoj(kk) = jang(kk)
!          tnljm%lj(kk)   = (2*lang(kk)+jang(kk)-1)/2
!          tnljm%twom(kk) = mjang(kk)

        do ia=1,HO%NLEV
         jnla=tnljm%n(ia) ! nlindex(ia)
	 jla =tnljm%l(ia) ! lang(ia)
	 jja =tnljm%twoj(ia) ! jang(ia)
	 jma =tnljm%twom(ia) ! mjang(ia)
	 jta =tnljm%t(ia)    ! mtisos(ia)
         do ib=1,HO%NLEV
         jnlb=tnljm%n(ib) ! nlindex(ib)
         jlb =tnljm%l(ib) ! lang(ib)
         jjb =tnljm%twoj(ib) ! jang(ib)
         jmb =tnljm%twom(ib) ! mjang(ib)
         jtb =tnljm%t(ib)    ! mtisos(ib)

	  delta_isos=0.d0
	  if (jta.eq.jtb) delta_isos=1.d0

	  factor=(((2.d0*jlb+1.d0)*5.d0)/(4.d0*pi*(2.d0*jla+1.d0)))**.5

	  call CJJ(4,2*jlb,2*jla,0,0,0,cbcomm)

	  radial=b2*rnla(jnla,jla,2,jnlb,jlb) !Rnl(jnla,jnlb)

          suma_m2=0.d0
          suma_m1=0.d0
          suma_0 =0.d0
          suma_p1=0.d0
          suma_p2=0.d0

          DO MLA=0,2*jla
	   MMLA=-jla+MLA
           DO MLB=0,2*jlb
           MMLB=-jlb+MLB

            DO IS=0,2,2
	     jms=-1+IS

             call CJJ(2*jla,1,jja,2*MMLA,jms,jma,cb1)
             call CJJ(2*jlb,1,jjb,2*MMLB,jms,jmb,cb2)

	     call CJJ(4,2*jlb,2*jla,-4,2*mmlb,2*mmla,cbm2)
	     call CJJ(4,2*jlb,2*jla,-2,2*mmlb,2*mmla,cbm1)
	     call CJJ(4,2*jlb,2*jla, 0,2*mmlb,2*mmla,cb_0)
	     call CJJ(4,2*jlb,2*jla, 2,2*mmlb,2*mmla,cbp1)
	     call CJJ(4,2*jlb,2*jla, 4,2*mmlb,2*mmla,cbp2)

 	     suma_m2=suma_m2+cb1*cb2*cbm2
 	     suma_m1=suma_m1+cb1*cb2*cbm1
 	     suma_0 =suma_0 +cb1*cb2*cb_0
 	     suma_p1=suma_p1+cb1*cb2*cbp1
 	     suma_p2=suma_p2+cb1*cb2*cbp2
            END DO
           END DO
          END DO

!        jmy: the factor sqrt(5./(4.*pi)) is divided in which case
!             beta_L = 4*pi/(3AR^L) * Q_L
           Q2_2t(ia,ib)=delta_isos*factor*cbcomm*radial*suma_m2/sqrt(5./(4.*pi))
           Q2_1t(ia,ib)=delta_isos*factor*cbcomm*radial*suma_m1/sqrt(5./(4.*pi))
           Q20t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_0 /sqrt(5./(4.*pi))
           Q21t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_p1/sqrt(5./(4.*pi))
           Q22t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_p2/sqrt(5./(4.*pi))

         end do
        end do
        end subroutine

!    ......................................................
        subroutine q2mume_IsoV(Q2_2t,Q2_1t,Q20t,Q21t,Q22t)
!    ......................................................

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

        double precision rnla

        DIMENSION Rnl(HO%nmax,HO%nmax) ! (2,2)
        DIMENSION Q2_2t(HO%NLEV,HO%NLEV)
        DIMENSION Q2_1t(HO%NLEV,HO%NLEV)
        DIMENSION Q20t(HO%NLEV,HO%NLEV)
        DIMENSION Q21t(HO%NLEV,HO%NLEV)
        DIMENSION Q22t(HO%NLEV,HO%NLEV)

        b2=HO%b_osc**2

!initializing

        do ii=1,HO%NLEV
         do jj=1,HO%NLEV
         Q2_2t(jj,ii)=zero
         Q2_1t(jj,ii)=zero
         Q20t(jj,ii)=zero
         Q21t(jj,ii)=zero
         Q22t(jj,ii)=zero
         end do
        end do

        do ia=1,HO%NLEV
         jnla=tnljm%n(ia) ! nlindex(ia)
         jla =tnljm%l(ia) ! lang(ia)
         jja =tnljm%twoj(ia) ! jang(ia)
         jma =tnljm%twom(ia) ! mjang(ia)
         jta =tnljm%t(ia)    ! mtisos(ia)
         do ib=1,HO%NLEV
         jnlb=tnljm%n(ib) ! nlindex(ib)
         jlb =tnljm%l(ib) ! lang(ib)
         jjb =tnljm%twoj(ib) ! jang(ib)
         jmb =tnljm%twom(ib) ! mjang(ib)
         jtb =tnljm%t(ib)    ! mtisos(ib)

          delta_isos=0.d0
          if (jta.eq.jtb .and. jta.eq.1)  delta_isos= 1.d0       ! isospin should be the same
          if (jta.eq.jtb .and. jta.eq.-1) delta_isos=-1.d0       ! isospin should be the same

          factor=(((2.d0*jlb+1.d0)*5.d0)/(4.d0*pi*(2.d0*jla+1.d0)))**.5

          call CJJ(4,2*jlb,2*jla,0,0,0,cbcomm)

          radial=b2*rnla(jnla,jla,2,jnlb,jlb) !Rnl(jnla,jnlb)

          suma_m2=0.d0
          suma_m1=0.d0
          suma_0 =0.d0
          suma_p1=0.d0
          suma_p2=0.d0

          DO MLA=0,2*jla
           MMLA=-jla+MLA
           DO MLB=0,2*jlb
           MMLB=-jlb+MLB

            DO IS=0,2,2
             jms=-1+IS

             call CJJ(2*jla,1,jja,2*MMLA,jms,jma,cb1)
             call CJJ(2*jlb,1,jjb,2*MMLB,jms,jmb,cb2)

             call CJJ(4,2*jlb,2*jla,-4,2*mmlb,2*mmla,cbm2)
             call CJJ(4,2*jlb,2*jla,-2,2*mmlb,2*mmla,cbm1)
             call CJJ(4,2*jlb,2*jla, 0,2*mmlb,2*mmla,cb_0)
             call CJJ(4,2*jlb,2*jla, 2,2*mmlb,2*mmla,cbp1)
             call CJJ(4,2*jlb,2*jla, 4,2*mmlb,2*mmla,cbp2)

             suma_m2=suma_m2+cb1*cb2*cbm2
             suma_m1=suma_m1+cb1*cb2*cbm1
             suma_0 =suma_0 +cb1*cb2*cb_0
             suma_p1=suma_p1+cb1*cb2*cbp1
             suma_p2=suma_p2+cb1*cb2*cbp2
            END DO
           END DO
          END DO

!        jmy: the factor sqrt(5./(4.*pi)) is divided in which case
!             beta_L = 4*pi/(3AR^L) * Q_L
           Q2_2t(ia,ib)=delta_isos*factor*cbcomm*radial*suma_m2/sqrt(5./(4.*pi))
           Q2_1t(ia,ib)=delta_isos*factor*cbcomm*radial*suma_m1/sqrt(5./(4.*pi))
           Q20t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_0 /sqrt(5./(4.*pi))
           Q21t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_p1/sqrt(5./(4.*pi))
           Q22t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_p2/sqrt(5./(4.*pi))

         end do
        end do
        end subroutine

!    ......................................................
        subroutine q2mume_KB(Q2_2t,Q2_1t,Q20t,Q21t,Q22t)
!    ......................................................
!       Baranger and Kumar defintion:
!       M. Baranger and K. Kumar, Nucl. Phys. A 110, 490 (1968).
!       Q/b^2 = sqrt(16*pi/5)[e_n*<r^2*Y_2> /b^2 + e_p *<r^2 Y_2>/b^2],
!       where, e_n =2N/A, e_p = 2Z/A, to be checked ...
!
        USE VAPHFB_PAR
        implicit real*8 (a-h,o-z)

        double precision rnla

        DIMENSION Rnl(HO%nmax,HO%nmax) ! (2,2)
        DIMENSION Q2_2t(HO%NLEV,HO%NLEV)
        DIMENSION Q2_1t(HO%NLEV,HO%NLEV)
        DIMENSION Q20t(HO%NLEV,HO%NLEV)
        DIMENSION Q21t(HO%NLEV,HO%NLEV)
        DIMENSION Q22t(HO%NLEV,HO%NLEV)

        b2=HO%b_osc**2
        b2   = 4.2627833 !1.d0
!       ...................................... red_fac = (3+1.5)/(3+2.5)
!        fac  = 2.d0/(sqrt(16*pi/5.d0))
        fac  = sqrt(5.d0/(4*pi))

!       ................................................
!        write(*,*) nucleon(0),nucleon(1),nucleon(2),facn,facp
!initializing

        do ii=1,HO%NLEV
         do jj=1,HO%NLEV
         Q2_2t(jj,ii)=zero
         Q2_1t(jj,ii)=zero
         Q20t(jj,ii)=zero
         Q21t(jj,ii)=zero
         Q22t(jj,ii)=zero
         end do
        end do

        do ia=1,HO%NLEV
         jnla=tnljm%n(ia) ! nlindex(ia)
         jla =tnljm%l(ia) ! lang(ia)
         jja =tnljm%twoj(ia) ! jang(ia)
         jma =tnljm%twom(ia) ! mjang(ia)
         jta =tnljm%t(ia)    ! mtisos(ia)
         do ib=1,HO%NLEV
         jnlb=tnljm%n(ib) ! nlindex(ib)
         jlb =tnljm%l(ib) ! lang(ib)
         jjb =tnljm%twoj(ib) ! jang(ib)
         jmb =tnljm%twom(ib) ! mjang(ib)
         jtb =tnljm%t(ib)    ! mtisos(ib)

          delta_isos=0.d0
          if (jta.eq.jtb )  delta_isos = fac       ! iso

          factor=(((2.d0*jlb+1.d0)*5.d0)/(4.d0*pi*(2.d0*jla+1.d0)))**.5

          call CJJ(4,2*jlb,2*jla,0,0,0,cbcomm)

          radial=rnla(jnla,jla,2,jnlb,jlb)*b2 !Rnl(jnla,jnlb)

          suma_m2=0.d0
          suma_m1=0.d0
          suma_0 =0.d0
          suma_p1=0.d0
          suma_p2=0.d0

          DO MLA=0,2*jla
           MMLA=-jla+MLA
           DO MLB=0,2*jlb
           MMLB=-jlb+MLB

            DO IS=0,2,2
             jms=-1+IS

             call CJJ(2*jla,1,jja,2*MMLA,jms,jma,cb1)
             call CJJ(2*jlb,1,jjb,2*MMLB,jms,jmb,cb2)

             call CJJ(4,2*jlb,2*jla,-4,2*mmlb,2*mmla,cbm2)
             call CJJ(4,2*jlb,2*jla,-2,2*mmlb,2*mmla,cbm1)
             call CJJ(4,2*jlb,2*jla, 0,2*mmlb,2*mmla,cb_0)
             call CJJ(4,2*jlb,2*jla, 2,2*mmlb,2*mmla,cbp1)
             call CJJ(4,2*jlb,2*jla, 4,2*mmlb,2*mmla,cbp2)

             suma_m2=suma_m2+cb1*cb2*cbm2
             suma_m1=suma_m1+cb1*cb2*cbm1
             suma_0 =suma_0 +cb1*cb2*cb_0
             suma_p1=suma_p1+cb1*cb2*cbp1
             suma_p2=suma_p2+cb1*cb2*cbp2
            END DO
           END DO
          END DO

!        jmy: the factor sqrt(5./(4.*pi)) is divided in which case
!             beta_L = 4*pi/(3AR^L) * Q_L
           Q2_2t(ia,ib)=delta_isos*factor*cbcomm*radial*suma_m2/sqrt(5./(4.*pi))
           Q2_1t(ia,ib)=delta_isos*factor*cbcomm*radial*suma_m1/sqrt(5./(4.*pi))
           Q20t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_0 /sqrt(5./(4.*pi))
           Q21t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_p1/sqrt(5./(4.*pi))
           Q22t(ia,ib) =delta_isos*factor*cbcomm*radial*suma_p2/sqrt(5./(4.*pi))

          if(abs(Q20t(ia,ib)).gt.1.d-5) write(191,'(2i4,f10.5)') ia,ib,Q20t(ia,ib)

         end do
        end do

        end subroutine


      SUBROUTINE GDALMG(MODEL,TM,GDLAT,GDLON,GDALT,X,Y,Z,F,H,DEC,AINC)
C ****  GEODETIC VERSION OF GEOMAGNETIC FIELD SUBROUTINE
C ****  PROGRAM DESIGNED AND TESTED BY G D MEAD AND E G STASSINOPOULOS,
C ****  CODE 641, NASA GODDARD SPACE FLT CTR, GREENBELT, MD 20771
C***INPUT   MODEL = 1-7; CHOICE OF SEVEN MODELS - SEE ALLMAG
C           TM = TIME IN YEARS FOR DESIRED FIELD (E.G. 1971.25)
C           GDLAT = GEODETIC LATITUDE (DEGREES)
C           GDLON = EAST LONGITUDE (DEGREES)
C           GDALT = ALTITUDE ABOVE GEOID (KMS)
C***OUTPUT  X,Y,Z = GEODETIC FIELD COMPONENTS (GAUSS)
C           F = MAGNITUDE OF FIELD (GAUSS)
C           H = HORIZONTAL INTENSITY (GAUSS)
C           DEC, AINC = DECLINATION AND INCLINATION ANGLES (DEGREES)
C***  NOTE  FOR GREATEST EFFICIENCY, COMPLETE ALL CALCULATIONS WITH ONE
C     MODEL AND ONE TIME BEFORE CHANGING MODEL OR TIME.
C   REFERENCE GEOID IS THAT ADOPTED BY IAU IN 1964
      IMPLICIT REAL*8(A-H,O-Z)
      DATA RAD,A,AB2,E2/57.29578D0,6378.165D0,1.0067397D0,.0067397D0/
      SINLAT = DSIN(GDLAT/RAD)
      COSLAT = DSQRT(1.-SINLAT**2)
      IF(MODEL.EQ.6) GO TO 2
    1 SINBET = SINLAT /DSQRT(SINLAT**2+(AB2*COSLAT)**2)
C***   BETA = GEOCENTRIC LATITUDE AT SURFACE OF GEOID
      COSBET =DSQRT(1.-SINBET*SINBET)
      RGEOID = A /DSQRT(1.+E2*SINBET*SINBET)
      XKM = RGEOID*COSBET + GDALT*COSLAT
      YKM = RGEOID*SINBET + GDALT*SINLAT
      RKM = DSQRT(XKM**2+YKM**2)
      ST = XKM/RKM
      CT = YKM/RKM
      GO TO 3
    2 RKM = 6371.2 + GDALT
      ST = COSLAT
      CT = SINLAT
    3 SP = DSIN(GDLON/RAD)
      CP = DCOS(GDLON/RAD)
      CALL ALLMAG(MODEL,TM,RKM,ST,CT,SP,CP,BR,BT,Y,F)
      SIND = ST*SINLAT - CT*COSLAT
      COSD = CT*SINLAT + ST*COSLAT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     X = -BT*COSD - BR*SIND
C     Z =  BT*SIND - BR*COSD
C   REPLACE BY THE FOLLOWING CARDS
C    IN THIS CASE THE VECTOR OF FIELD IS OUTWARD POSITIVE
      X=-BT
      Z=BR
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      H = DSQRT(X*X+Y*Y)
      DEC = RAD * DATAN2(Y,X)
      AINC = RAD * DATAN(Z/H)
      RETURN
      END


subroutine get_remap_pix_len(x1min, x1max, grid1, x2min, x2max, grid2, pixlen)
  ! Find pixel weight length.
  !
  ! Parameters
  ! ----------
  ! x1min : float
  !   Minimum in grid 1.
  ! x1max : float
  !   Maximum in grid 1.
  ! grid1 : int
  !   Number of grid points in grid 1.
  ! x2min : float
  !   Minimum in grid 2.
  ! x2max : float
  !   Maximum in grid 2.
  ! grid2 : int
  !   Number of grid points in grid 2
  !
  ! Returns
  ! -------
  ! pixlen : int
  !   Length of pixel mapping indices and weights.

  implicit none

  ! Parameter declarations

  integer, parameter :: dp = kind(1.d0)

  integer, intent(in) :: grid1, grid2
  real(kind=dp), intent(in) :: x1min, x1max, x2min, x2max

  real(kind=dp) :: boxsize1, boxsize2, dx1, dx2

  integer, intent(out) :: pixlen

  ! Function

  boxsize1 = x1max - x1min
  boxsize2 = x2max - x2min

  dx1 = boxsize1 / real(grid1)
  dx2 = boxsize2 / real(grid2)

  pixlen = int(floor(dx2/dx1)) + 2

end subroutine get_remap_pix_len

subroutine which_pix(xmin, dx, x, pix)

  ! Find pixel along a defined grid.
  !
  ! Parameters
  ! ----------
  ! xmin : float
  !   Minimum along the grid.
  ! dx : float
  !   pixel width.
  ! x : float
  !   A point for which we would like to determine
  !
  ! Returns
  ! -------
  ! pix : int
  !   The pixel the point corresponds to.

  implicit none

  ! Parameter declarations

  integer, parameter :: dp = kind(1.d0)

  real(kind=dp), intent(in) :: xmin, dx, x
  integer, intent(out) :: pix

  ! Function

  pix = int(floor((x-xmin)/dx))

end subroutine which_pix

subroutine pix1dto2d(xpix, ypix, xlen, ylen, ygrid, pix)

  ! Maps pixels given along a single axis in x and y onto a 2d grid flattened.
  !
  ! Parameters
  ! ----------
  ! xpix : int
  !   Pixel indices along the x axis grid.
  ! ypix : int
  !   Pixel indices along the y axis grid.
  ! xlen : int
  !   Size of the xpix.
  ! ylen : int
  !   Size of the ypix.
  ! ygrid : int
  !   Length of y axis grid.
  !
  ! Returns
  ! -------
  ! pix : int
  !   2d grid pixel.

  implicit none

  integer, intent(in) :: xlen, ylen, ygrid
  integer, intent(in) :: xpix(xlen), ypix(ylen)
  integer, intent(out) :: pix(xlen*ylen)

  integer :: i, j, ii

  ii = 1

  do i = 1, xlen
    do j = 1, ylen
      if ((xpix(i) .NE. -1) .AND. (ypix(j) .NE. -1)) then
        pix(ii) = ypix(j) + ygrid*xpix(i)
      else
        pix(ii) = -1
      end if
      ii = ii + 1
    end do
  end do

end subroutine pix1dto2d

subroutine pix1dto3d(xpix, ypix, zpix, xlen, ylen, zlen, ygrid, zgrid, pix)

  ! Maps pixels given along a single axis in x, y and z onto a 3d grid flattened.
  !
  ! Parameters
  ! ----------
  ! xpix : int
  !   Pixel indices along the x axis grid.
  ! ypix : int
  !   Pixel indices along the y axis grid.
  ! xlen : int
  !   Size of the xpix.
  ! ylen : int
  !   Size of the ypix.
  ! zlen : int
  !   Size of the zpix.
  ! ygrid : int
  !   Length of y axis grid.
  ! zgrid : int
  !   Length of z axis grid.
  !
  ! Returns
  ! -------
  ! pix : int
  !   2d grid pixel.

  implicit none

  integer, intent(in) :: xlen, ylen, zlen, ygrid, zgrid
  integer, intent(in) :: xpix(xlen), ypix(ylen), zpix(zlen)
  integer, intent(out) :: pix(xlen*ylen*zlen)

  integer :: i, j, k, ii

  ii = 1

  do i = 1, xlen
    do j = 1, ylen
      do k = 1, zlen
        if ((xpix(i) .NE. -1) .AND. (ypix(j) .NE. -1) .AND. (zpix(k) .NE. -1)) then
          pix(ii) = zpix(k) + zgrid*(ypix(j) + ygrid*xpix(i))
        else
          pix(ii) = -1
        end if
        ii = ii + 1
      end do
    end do
  end do

end subroutine pix1dto3d

subroutine remap_1d_grid2grid_pixel(x1min, x1max, grid1, x2min, x2max, grid2, which2pix, pixlen, pix, weights)

  ! Computes the exact weights for mapping a single pixel from a new grid (denoted by 2) onto an initial grid
  ! (denoted with 1).
  !
  ! Parameters
  ! ----------
  ! x1min : float
  !   Minimum in grid 1.
  ! x1max : float
  !   Maximum in grid 1.
  ! grid1 : int
  !   Number of grid points in grid 1.
  ! x2min : float
  !   Minimum in grid 2.
  ! x2max : float
  !   Maximum in grid 2.
  ! grid2 : int
  !   Number of grid points in grid 2.
  ! which2pix : int
  !   Pixel in grid 2.
  ! pixlen : int
  !   Length of pixel mapping indices and weights.
  !
  ! Returns
  ! -------
  ! pix : int
  !   Pixels to map 2 to 1.
  ! weights : floats
  !   Weights to map 2 to 1.

  implicit none

  ! Parameter declarations

  integer, parameter :: dp = kind(1.d0)

  integer, intent(in) :: grid1, grid2, which2pix, pixlen
  real(kind=dp), intent(in) :: x1min, x1max, x2min, x2max
  integer, intent(out) :: pix(pixlen)
  real(kind=dp), intent(out) :: weights(pixlen)

  real(kind=dp) :: boxsize1, boxsize2, dx1, dx2, x1edge1, x1edge2, x2edge1, x2edge2
  integer :: i, pix1, pix2

  ! Function

  boxsize1 = x1max - x1min
  boxsize2 = x2max - x2min

  dx1 = boxsize1 / real(grid1)
  dx2 = boxsize2 / real(grid2)

  x2edge1 = x2min + dx2*real(which2pix)
  x2edge2 = x2min + dx2*real(which2pix+1)

  call which_pix(x1min, dx1, x2edge1, pix1)
  call which_pix(x1min, dx1, x2edge2, pix2)

  if (pix1 .NE. pix2) then
    do i = 1, pixlen
      pix(i) = pix1 + i-1
      if ((pix(i) .GE. 0) .AND. (pix(i) .LT. grid1)) then
        x1edge1 = x1min + dx1*real(pix(i))
        x1edge2 = x1min + dx1*real(pix(i)+1)
        if ((x2edge1 .GE. x1edge1) .AND. (x2edge2 .LE. x1edge2)) then
          weights(i) = (x2edge2 - x2edge1)/(x2edge2 - x2edge1)
        else if ((x2edge1 .LT. x1edge1) .AND. (x2edge2 .LE. x1edge2) .AND. (x2edge2 .GT. x1edge1)) then
          weights(i) = (x2edge2 - x1edge1)/(x2edge2 - x2edge1)
        else if ((x2edge1 .GE. x1edge1) .AND. (x2edge1 .LT. x1edge2) .AND. (x2edge2 .GT. x1edge2)) then
          weights(i) = (x1edge2 - x2edge1)/(x2edge2 - x2edge1)
        else if ((x2edge1 .LT. x1edge1) .AND. (x2edge2 .GT. x1edge2)) then
          weights(i) = (x1edge2 - x1edge1)/(x2edge2 - x2edge1)
        else
          weights(i) = 0.
          pix(i) = -1
        end if
      else
        weights(i) = 0.
        pix(i) = -1
      end if

    end do
  else if (pix1 .NE. -1) then
    do i = 1, pixlen
      pix(i) = pix1 + i-1
      if ((pix(i) .GE. 0) .AND. (pix(i) .LT. grid1)) then
        if (i .EQ. 1) then
          weights(i) = 1.
        else
          weights(i) = 0.
        end if
      else
        weights(i) = 0.
        pix(i) = -1
      end if
    end do
  end if

end subroutine remap_1d_grid2grid_pixel


        program generate_rand
        implicit none
        integer i,k,n
	real sum
        real*8 drand48

	sum =0.0
	print*,'input k and N'
	read*,k,n
        do i=1, n
            sum = sum + drand48()**k
        enddo
	sum=sum/n
            print *,'the k-th moment =', sum
        end


program om

  use command_line, only: cl_getarg, cl_iargc

  real, dimension(:), allocatable :: w, A
  character (500) :: runname, c
  integer, dimension (1) :: max_loc, jlo, jhi
  integer :: i, imax, ierr
  complex :: omega
  real :: wr, wi

  if (cl_iargc() /= 0) then
     call cl_getarg (1, runname, 500, ierr)
  else
     write (*,*) 'runname = ?'
     read (*,*) runname
  end if

  open (unit=12, file=trim(runname)//'.w')
  imax=0
  do
     imax = imax + 1
     read (12, *, end=100)
  end do

100 rewind(12)

  allocate (w(imax), A(imax))

  do i=1,imax-1
     read (12, *) c, w(i), c, A(i)
  end do
  close (12)

  max_loc = maxloc (A)

  jlo = minloc ((A(1:max_loc(1))-0.5*A(max_loc(1)))**2)
  jhi = minloc ((A(max_loc(1):imax-1)-0.5*A(max_loc(1)))**2)+max_loc(1)

  wr = w(max_loc(1))
  wi = (w(jhi(1))-w(jlo(1)))/4.

! spot testing (direct evaluation of (wr, wi)) shows need
! for these corrections.  Should investigate this further.

  wr = wr * 0.98
  wi = wi * 1.11

  omega = cmplx(wr, -wi)
  write (*,*) 'omega/k_par v_A ~ ',omega
  write (*,*) 'Log10 (omega/k_par v_A) ~ ',alog10(real(omega))
  write (*,*) 'Log10 (gamma/omega) = ',alog10(wi/wr)

end program om


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MMergeSort

    use MSort

    implicit none
    private

    type, extends(TSort), public :: TMergeSort
    contains
        procedure, nopass :: sort => sortOriginalWrapper

        procedure, nopass :: sortOriginalWrapper
    end type
contains
    subroutine sortOriginalWrapper(array)
        integer, dimension(:), intent(in out) :: array

        call sortOriginal(array, 1, size(array))
    end subroutine

    recursive subroutine sortOriginal(array, begin, end)
        integer, dimension(:), intent(in out) :: array
        integer, intent(in)                   :: begin
        integer, intent(in)                   :: end

        integer middle

        if (begin < end) then
            middle = begin + ((end - begin) / 2)

            call sortOriginal(array, begin, middle)
            call sortOriginal(array, middle + 1, end)

            call mergeOriginal(array, begin, middle, end)
        end if
    end subroutine

    subroutine mergeOriginal(array, begin, middle, end)
        integer, dimension(:), intent(in out) :: array
        integer, intent(in)                   :: begin
        integer, intent(in)                   :: middle
        integer, intent(in)                   :: end

        integer index, jndex
        integer left, right
        integer buffer(size(array))

        index = begin
        left  = begin
        right = middle + 1

        do while ((left <= middle) .and. (right <= end))
            if (array(left) <= array(right)) then
                buffer(index) = array(left)
                left = left + 1
            else
                buffer(index) = array(right)
                right = right + 1
            end if

            index = index + 1
        end do

        if (left > middle) then
            do jndex = right, end
                buffer(index) = array(jndex)
                index = index + 1
            end do
        else
            do jndex = left, middle
                buffer(index) = array(jndex)
                index = index + 1
            end do
        end if

        array(begin:end) = buffer(begin:end)
    end subroutine
end module


      REAL*8  function getphirzfunc(radius)
      implicit none
      REAL*8 radius
      getphirzfunc = radius*radius
      return
      end
      REAL*8  function getgradphirzfunc(radius)
      implicit none
      REAL*8 radius
      getgradphirzfunc = (2.0d0)*radius
      return
      end
      REAL*8  function getlaplphirzfunc(radius)
      implicit none
      REAL*8 radius
      getlaplphirzfunc = (4.0d0)
      return
      end
        subroutine GETPHI(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,probhi
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      REAL*8 probhi(0:1)
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
        integer i,j
        REAL*8 x(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          x(1) = (j+(0.500d0))*dx(1) + problo(1)
          call getphipoint(phi(i,j),freq,x)
      enddo
      enddo
        return
        end
        subroutine GETMAGRESIST(
     &           mag
     &           ,imaglo0,imaglo1
     &           ,imaghi0,imaghi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           ,icomp
     &           ,whichmag
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer imaglo0,imaglo1
      integer imaghi0,imaghi1
      REAL*8 mag(
     &           imaglo0:imaghi0,
     &           imaglo1:imaghi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
      integer icomp
      integer whichmag
        integer i,j
        REAL*8 x(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          x(1) = (j+(0.500d0))*dx(1) + problo(1)
          call getmagpointresist(mag(i,j),freq,x,
     $         icomp, whichmag)
      enddo
      enddo
        return
        end
        subroutine GETMAGPOINTRESIST(
     &           mag
     &           ,freq
     &           ,xval
     &           ,icomp
     &           ,whichmag
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 mag
      REAL*8 freq(0:1)
      REAL*8 xval(0:1)
      integer icomp
      integer whichmag
        REAL*8  x,y
        integer i,j
        if(icomp.eq.2) then
           mag = (0.0d0)
           return
        endif
        i = icomp
        j = max(1-icomp, 0)
        if(whichmag.eq. 2) then
           x = freq(i)*xval(i)
           y = freq(j)*xval(j)
           mag = sin(y)
        elseif(whichmag.eq. 1) then
           x = freq(icomp)*xval(icomp)
           mag = sin(x)
        elseif(whichmag.eq.0) then
           x = xval(icomp)
           mag = x*x
        elseif(whichmag.eq.4) then
           x = xval(icomp)
           if(icomp .eq. 0) then
              mag = x
           else
              mag = (0.0d0)
           endif
        else
           call MayDay_Error()
        endif
        return
        end
        subroutine GETETARESIST(
     &           eta
     &           ,ietalo0,ietalo1
     &           ,ietahi0,ietahi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           ,idir
     &           ,eps
     &           ,whicheta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer ietalo0,ietalo1
      integer ietahi0,ietahi1
      REAL*8 eta(
     &           ietalo0:ietahi0,
     &           ietalo1:ietahi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
      integer idir
      REAL*8 eps
      integer whicheta
        integer i,j,jdir
        REAL*8 x(0:2 -1)
        integer iv(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
           iv(0) = i
           iv(1) = j
           do jdir = 0, 2 -1
              if(idir .eq. jdir) then
                 x(jdir) = iv(jdir)*dx(jdir) + problo(jdir)
              else
                 x(jdir) = (iv(jdir)+(0.500d0))*dx(jdir) + problo(jdir)
              endif
           enddo
          call getetapointresist(eta(i,j),freq,x,
     $         idir, eps, whicheta)
      enddo
      enddo
        return
        end
        subroutine GETETAPOINTRESIST(
     &           eta
     &           ,freq
     &           ,xval
     &           ,idir
     &           ,eps
     &           ,whicheta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 eta
      REAL*8 freq(0:1)
      REAL*8 xval(0:1)
      integer idir
      REAL*8 eps
      integer whicheta
        REAL*8 x, y
        if(whicheta.eq. 1) then
           x = freq(0)*xval(0)
           y = freq(1)*xval(1)
           eta  = (1.0d0) + eps*(sin(x) + sin(y))
        elseif(whicheta.eq.0) then
           eta = (1.0d0)
        elseif(whicheta.eq.3) then
           eta = (0.500d0)
        else
           call MayDay_Error()
        endif
        return
        end
        subroutine GETBETAVISCOUS(
     &           beta
     &           ,ibetalo0,ibetalo1
     &           ,ibetahi0,ibetahi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,eps
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           ,whichbeta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer ibetalo0,ibetalo1
      integer ibetahi0,ibetahi1
      REAL*8 beta(
     &           ibetalo0:ibetahi0,
     &           ibetalo1:ibetahi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      REAL*8 eps
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
      integer whichbeta
        integer i,j,jdir
        REAL*8 x(0:2 -1)
        integer iv(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
           iv(0) = i
           iv(1) = j
           do jdir = 0, 2 -1
              x(jdir) = (iv(jdir)+(0.500d0))*dx(jdir) + problo(jdir)
           enddo
          call getbetapointviscous(beta(i,j),freq,x, eps, whichbeta)
      enddo
      enddo
        return
        end
        subroutine GETBETAPOINTVISCOUS(
     &           beta
     &           ,freq
     &           ,xval
     &           ,eps
     &           ,whichbeta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 beta
      REAL*8 freq(0:1)
      REAL*8 xval(0:1)
      REAL*8 eps
      integer whichbeta
        REAL*8 x, y
        if(whichbeta.eq. 1) then
           x = freq(0)*xval(0)
           y = freq(1)*xval(1)
           beta  = (1.0d0) + eps*(sin(x) + sin(y))
        elseif(whichbeta.eq.0) then
           beta = (1.0d0)
        else
           call MayDay_Error()
        endif
        return
        end
        subroutine GETKLBRESIST(
     &           klb
     &           ,iklblo0,iklblo1
     &           ,iklbhi0,iklbhi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,alpha
     &           ,beta
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           ,icomp
     &           ,eps
     &           ,whichmag
     &           ,whicheta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer iklblo0,iklblo1
      integer iklbhi0,iklbhi1
      REAL*8 klb(
     &           iklblo0:iklbhi0,
     &           iklblo1:iklbhi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      REAL*8 alpha
      REAL*8 beta
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
      integer icomp
      REAL*8 eps
      integer whichmag
      integer whicheta
        integer i,j
        REAL*8 x(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          x(1) = (j+(0.500d0))*dx(1) + problo(1)
          call getklbpointresist(klb(i,j),freq,x,
     $         alpha, beta, icomp, eps, whichmag, whicheta)
      enddo
      enddo
        return
        end
        subroutine GETKLBPOINTRESIST(
     &           klb
     &           ,freq
     &           ,xvec
     &           ,alpha
     &           ,beta
     &           ,icomp
     &           ,eps
     &           ,whichmag
     &           ,whicheta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 klb
      REAL*8 freq(0:1)
      REAL*8 xvec(0:1)
      REAL*8 alpha
      REAL*8 beta
      integer icomp
      REAL*8 eps
      integer whichmag
      integer whicheta
        REAL*8  fx,fy
        REAL*8  x,y,  termone
        REAL*8  freqx,freqy, mag, divf, eta
        integer i,j
        if(icomp.eq.2) then
           klb = (0.0d0)
           return
        endif
        i = icomp
        j = max(1-icomp, 0)
        call getetapointresist(eta,freq,xvec, icomp, eps, whicheta)
        call getmagpointresist(mag,freq,xvec, icomp, whichmag)
        freqx = freq(i)
        freqy = freq(j)
        x = xvec(i)
        y = xvec(j)
        if((whichmag.eq. 2).and.(whicheta.eq.0)) then
           divf = -(freqy*freqy*sin(freqy*y))
        elseif((whichmag.eq. 3).and.(whicheta.eq.0)) then
           call getlofphipoint(klb, freq, xvec, alpha, beta)
           goto  123
        elseif((whichmag.eq. 2).and.(whicheta.eq.1)) then
           fx = freqx*x
           fy = freqy*y
           divf = (freqy*cos(fy) - freqx*cos(fx))*(eps*freqy*cos(fy)) -
     &freqy*freqy*eta*sin(fy)
        elseif((whichmag.eq. 1).and.(whicheta.eq.1)) then
           termone =
     $          freqx*cos(freqx*x) +
     $          freqy*cos(freqy*y)
          divf = eps*freqx*cos(freqx*x)*termone
     $         -freqx*freqx*sin(freqx*x)*eta
        elseif((whichmag.eq.0).and.(whicheta.eq.0)) then
           divf = (2.0d0)
        elseif((whichmag.eq.4).and.(whicheta.eq.0)) then
           divf = (0.0d0)
        elseif((whichmag.eq.1).and.(whicheta.eq.0)) then
           divf = -freqx*freqx*sin(freqx*x)
        else
           call MayDay_Error()
        endif
        klb = alpha*mag  + beta*divf
  123   continue
        return
        end
        subroutine GETKLVVISCOUS(
     &           klb
     &           ,iklblo0,iklblo1
     &           ,iklbhi0,iklbhi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,alpha
     &           ,beta
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           ,icomp
     &           ,eps
     &           ,whichvel
     &           ,whicheta
     &           ,whichlambda
     &           ,lambdafactor
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer iklblo0,iklblo1
      integer iklbhi0,iklbhi1
      REAL*8 klb(
     &           iklblo0:iklbhi0,
     &           iklblo1:iklbhi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      REAL*8 alpha
      REAL*8 beta
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
      integer icomp
      REAL*8 eps
      integer whichvel
      integer whicheta
      integer whichlambda
      REAL*8 lambdafactor
        integer i,j
        REAL*8 x(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          x(1) = (j+(0.500d0))*dx(1) + problo(1)
          call getklvpointviscous(klb(i,j),
     $         freq,x, alpha, beta, icomp, eps,
     $         whichvel, whicheta, whichlambda, lambdafactor)
      enddo
      enddo
        return
        end
        subroutine GETKLVPOINTVISCOUS(
     &           klv
     &           ,freq
     &           ,xvec
     &           ,alpha
     &           ,beta
     &           ,icomp
     &           ,eps
     &           ,whichvel
     &           ,whicheta
     &           ,whichlambda
     &           ,lambdafactor
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 klv
      REAL*8 freq(0:1)
      REAL*8 xvec(0:1)
      REAL*8 alpha
      REAL*8 beta
      integer icomp
      REAL*8 eps
      integer whichvel
      integer whicheta
      integer whichlambda
      REAL*8 lambdafactor
        REAL*8  x,y,    lambda
        REAL*8  freqx,freqy, vel, divf, eta
        REAL*8 fx,fy
        integer i,j
        i = icomp
        j = max(1-icomp, 0)
        call getetapointresist(   eta,freq,xvec, icomp, eps, whicheta)
        if(whichlambda .eq. 2) then
           lambda = -lambdafactor*eta
        else
           call getetapointresist(lambda,freq,xvec, icomp, eps, whichlam
     &bda)
        endif
        call getmagpointresist(   vel,freq,xvec, icomp, whichvel)
        freqx = freq(i)
        freqy = freq(j)
        x = xvec(i)
        y = xvec(j)
        fx = freqx*x
        fy = freqy*y
        if((whichvel.eq.2).and.(whicheta.eq.0)) then
           divf = -freqy*freqy*sin(fy)
        else if((whichvel.eq.1).and.(whicheta.eq.3).and.(whichlambda.eq.
     &3)) then
           divf = -(3.0d0)*(0.500d0)*freqx*freqx*sin(fx)
        else if((whichvel.eq.1).and.(whicheta.eq.0).and.(whichlambda.eq.
     &0)) then
           divf = -(3.0d0)*freqx*freqx*sin(fx)
        else if((whichvel.eq.1).and.(whicheta.eq.0).and.(whichlambda.eq.
     &2)) then
           divf = -((2.0d0) - lambdafactor)*freqx*freqx*sin(fx)
        else if((whichvel.eq.1).and.(whicheta.eq.1).and.(whichlambda.eq.
     &1)) then
           divf =       -(3.0d0)*eta*freqx*freqx*sin(fx)
           divf = divf + (3.0d0)*eps*freqx*freqx*cos(fx)*cos(fx)
           divf = divf +       eps*freqx*freqy*cos(fx)*cos(fy)
        else if((whichvel.eq.1).and.(whicheta.eq.1).and.(whichlambda.eq.
     &2)) then
           divf =       -((2.0d0) - lambdafactor)*eta*freqx*freqx*sin(fx
     &)
           divf = divf + ((2.0d0) - lambdafactor)*eps*freqx*freqx*cos(fx
     &)*cos(fx)
           divf = divf -       (lambdafactor)*eps*freqx*freqy*cos(fx)*co
     &s(fy)
        else if((whichvel.eq.2).and.(whicheta.eq.1)) then
           divf =       - eta*freqy*freqy*sin(fy)
           divf = divf + eps*freqy*cos(fy)*(freqy*cos(fy) + freqx*cos(fx
     &))
        else if(whichvel.eq.4) then
           divf = (0.0d0)
        else
           call MayDay_Error()
        endif
        klv = alpha*vel  + beta*divf
        return
        end
        subroutine GETPHIPOINT(
     &           phi
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 phi
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
        phi = sin(freq(0)*x(0))
     &                * sin(freq(1)*x(1))
        return
        end
        subroutine GETLOFPHIZPOLY(
     &           lofphi
     &           ,x
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 lofphi
      REAL*8 x(0:1)
      REAL*8 alpha
      REAL*8 beta
        REAL*8 phi, laplphi
        REAL*8 dist
        external getlaplphirzfunc
        REAL*8 getlaplphirzfunc
        external getphirzfunc
        REAL*8 getphirzfunc
        dist = abs(x(0))
        phi = getphirzfunc(dist)
        laplphi = getlaplphirzfunc(dist)
        lofphi = alpha*phi + beta*laplphi
        return
        end
        subroutine GETPHIRZPOLY(
     &           phi
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 phi
      REAL*8 x(0:1)
        REAL*8 dist
        external getphirzfunc
        REAL*8 getphirzfunc
        dist =abs(x(0))
        phi = getphirzfunc(dist)
        return
        end
      subroutine GETGRADPHIRZPOLY(
     &           gradphi
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 gradphi(0:1)
      REAL*8 x(0:1)
        REAL*8 dist
        external getgradphirzfunc
        REAL*8 getgradphirzfunc
        dist = abs(x(0))
        gradphi(0) = getgradphirzfunc(dist)
        gradphi(1) = (0.0d0)
        return
        end
        subroutine GETGRADPHIPOINT(
     &           gradphi
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 gradphi(0:1)
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
        gradphi(0) = freq(0) * cos(freq(0)*x(0)) * sin(freq(1)*x(1))
        gradphi(1) = freq(1) * sin(freq(0)*x(0)) * cos(freq(1)*x(1))
        return
        end
        subroutine GETLOFPHI(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1
     &           ,ilofphihi0,ilofphihi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,probhi
     &           ,alpha
     &           ,beta
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer ilofphilo0,ilofphilo1
      integer ilofphihi0,ilofphihi1
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      REAL*8 probhi(0:1)
      REAL*8 alpha
      REAL*8 beta
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
        integer i,j
        REAL*8 x(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          x(1) = (j+(0.500d0))*dx(1) + problo(1)
          call getlofphipoint(lofphi(i,j),freq,x,alpha,beta)
      enddo
      enddo
        return
        end
        subroutine GETLOFPHIPOINT(
     &           lofphi
     &           ,freq
     &           ,x
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 lofphi
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
      REAL*8 alpha
      REAL*8 beta
        REAL*8 fac,phi
        fac = -(freq(0)**2
     &                  + freq(1)**2)
        phi = (sin(freq(0)*x(0))
     &                 * sin(freq(1)*x(1)))
        lofphi = fac*phi
        lofphi = alpha*phi + beta*lofphi
        return
        end
        subroutine GETDBGPHI(
     &           dbgphi
     &           ,idbgphilo0,idbgphilo1
     &           ,idbgphihi0,idbgphihi1
     &           ,beta
     &           ,ibetalo0,ibetalo1
     &           ,ibetahi0,ibetahi1
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,probhi
     &           ,alpha
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer idbgphilo0,idbgphilo1
      integer idbgphihi0,idbgphihi1
      REAL*8 dbgphi(
     &           idbgphilo0:idbgphihi0,
     &           idbgphilo1:idbgphihi1)
      integer ibetalo0,ibetalo1
      integer ibetahi0,ibetahi1
      REAL*8 beta(
     &           ibetalo0:ibetahi0,
     &           ibetalo1:ibetahi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 problo(0:1)
      REAL*8 probhi(0:1)
      REAL*8 alpha
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
        integer i,j
        REAL*8 x(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          x(1) = (j+(0.500d0))*dx(1) + problo(1)
          call getdbgphipoint(dbgphi(i,j),
     &        beta(i,j),freq,x,alpha)
      enddo
      enddo
        return
        end
        subroutine GETDBGPHIPOINT(
     &           dbgphi
     &           ,beta
     &           ,freq
     &           ,x
     &           ,alpha
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 dbgphi
      REAL*8 beta
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
      REAL*8 alpha
        REAL*8 gradphi(0:2 -1),gradbeta(0:2 -1)
        REAL*8 alphaphiplusbetalapphi,gradbetadotgradphi
        call getbetapoint(beta,freq,x)
        call getlofphipoint(alphaphiplusbetalapphi,freq,x,alpha,beta)
        call getgradbetapoint(gradbeta,freq,x)
        call getgradphipoint(gradphi,freq,x)
        gradbetadotgradphi = gradbeta(0)*gradphi(0)
     &                               + gradbeta(1)*gradphi(1)
        dbgphi = alphaphiplusbetalapphi
        dbgphi = dbgphi + gradbetadotgradphi
        return
        end
        subroutine GETBETAPOINT(
     &           beta
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 beta
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
        beta = x(0)*x(0)
     &                 + x(1)*x(1)
        return
        end
        subroutine GETGRADBETAPOINT(
     &           gradbeta
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 gradbeta(0:1)
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
        integer idir
        do idir = 0, 2 -1
            gradbeta(idir) = (2.0d0)*x(idir)
        enddo
        return
        end
        subroutine GETBETAGRADPHIPOINT(
     &           gradphi
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 gradphi(0:1)
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
        integer idir
        REAL*8 beta
        call getbetapoint(beta,freq,x)
        call getgradphipoint(gradphi,freq,x)
        do idir = 0, 2 -1
           gradphi(idir) = gradphi(idir)*beta
        enddo
        return
        end
        subroutine GETSRC(
     &           src
     &           ,isrclo0,isrclo1
     &           ,isrchi0,isrchi1
     &           ,freq
     &           ,dx
     &           ,diffconst
     &           ,problo
     &           ,probhi
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer isrclo0,isrclo1
      integer isrchi0,isrchi1
      REAL*8 src(
     &           isrclo0:isrchi0,
     &           isrclo1:isrchi1)
      REAL*8 freq(0:1)
      REAL*8 dx(0:1)
      REAL*8 diffconst
      REAL*8 problo(0:1)
      REAL*8 probhi(0:1)
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
        integer i,j
        REAL*8 x(0:2 -1)
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          x(1) = (j+(0.500d0))*dx(1) + problo(1)
          call getsrcpoint(src(i,j),freq,x,diffconst)
      enddo
      enddo
        return
        end
        subroutine GETSRCPOINT(
     &           src
     &           ,freq
     &           ,x
     &           ,diffconst
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 src
      REAL*8 freq(0:1)
      REAL*8 x(0:1)
      REAL*8 diffconst
        REAL*8 fac,phi
        fac = -(freq(0)**2
     &                  + freq(1)**2)
        phi = (sin(freq(0)*x(0))
     &                 * sin(freq(1)*x(1)))
        src = (-fac*diffconst)*phi
        return
        end


SUBROUTINE  NTOI(value,nrow,grid,n,ind)
implicit none
INTEGER, INTENT(IN) :: nrow, n
REAL, INTENT(IN) :: value(nrow,1), grid(n,1)
INTEGER, INTENT(OUT) :: ind(nrow,1)
REAL, ALLOCATABLE :: ones(:,:), aux(:,:)
REAL :: step=0.0
ALLOCATE (aux(nrow,1))
aux = MIN(value,grid(n,1))
aux = MAX(aux,grid(1,1))
step = (grid(n,1)-grid(1,1))/(n-1)
ALLOCATE (ones(nrow,1))
ones = 1.0
ind = NINT(((aux-grid(1,1)*ones)/step)+ones)
DEALLOCATE(ones)
DEALLOCATE(aux)
RETURN
END subroutine


      SUBROUTINE MB05OY( JOB, N, LOW, IGH, A, LDA, SCALE, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To restore a matrix after it has been transformed by applying
C     balancing transformations (permutations and scalings), as
C     determined by LAPACK Library routine DGEBAL.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the type of backward transformation required,
C             as follows:
C             = 'N', do nothing, return immediately;
C             = 'P', do backward transformation for permutation only;
C             = 'S', do backward transformation for scaling only;
C             = 'B', do backward transformations for both permutation
C                    and scaling.
C             JOB must be the same as the argument JOB supplied
C             to DGEBAL.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     LOW     (input) INTEGER
C     IGH     (input) INTEGER
C             The integers LOW and IGH determined by DGEBAL.
C             1 <= LOW <= IGH <= N, if N > 0; LOW=1 and IGH=0, if N=0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix to be back-transformed.
C             On exit, the leading N-by-N part of this array contains
C             the transformed matrix.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     SCALE   (input) DOUBLE PRECISION array, dimension (N)
C             Details of the permutation and scaling factors, as
C             returned by DGEBAL.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Let P be a permutation matrix, and D a diagonal matrix of scaling
C     factors, both of order N. The routine computes
C                     -1
C        A <-- P D A D  P'.
C
C     where the permutation and scaling factors are encoded in the
C     array SCALE.
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C                               2
C     The algorithm requires O(N ) operations.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB05CY.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           IGH, INFO, LDA, LOW, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), SCALE(*)
C     .. Local Scalars ..
      INTEGER           I, II, J, K
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DSCAL, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 )THEN
         INFO = -2
      ELSE IF( LOW.LT.1 .OR. LOW.GT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( IGH.LT.MIN( LOW, N ) .OR. IGH.GT.N ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = -6
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB05OY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. LSAME( JOB, 'N' ) )
     $   RETURN
C
      IF ( .NOT.LSAME( JOB, 'P' ) .AND. IGH.NE.LOW ) THEN
C
         DO 20 I = LOW, IGH
            CALL DSCAL( N, SCALE(I), A(I,1), LDA )
   20    CONTINUE
C
         DO 40 J = LOW, IGH
            CALL DSCAL( N, ONE/SCALE(J), A(1,J), 1 )
   40    CONTINUE
C
      END IF
C
      IF( .NOT.LSAME( JOB, 'S' ) ) THEN
C
         DO 60 II = 1, N
            I = II
            IF ( I.LT.LOW .OR. I.GT.IGH ) THEN
               IF ( I.LT.LOW ) I = LOW - II
               K = SCALE(I)
               IF ( K.NE.I ) THEN
                  CALL DSWAP( N, A(I,1), LDA, A(K,1), LDA )
                  CALL DSWAP( N, A(1,I), 1, A(1,K), 1 )
               END IF
            END IF
   60    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of MB05OY ***
      END


*      subroutine delr(rwm2,rzm2,rhm2,thmu2,deltar,dr_bos,dr_fer)
      subroutine delr(deltar,dr_bos,dr_fer)
*---------------------------------------------------------------
      implicit none!
      include "s2n_declare.h"
*-------------------
*      real*8 thmu2,rwm2,rzm2,rhm2
*      real*8 ctw2,stw2,ctw4,lnctw
*      real*8 rhz,rhw,rhz2,rhw2
      real*8 rhz2,rhw2
      real*8 lnmuwm,lnmuzm,lnmuhm,lnctw
      real*8 pg0fer,drfer,drbos,drwfer,drwbos,deltar,dr_bos,dr_fer,dreal
*-
*      complex*16 cz2
      complex*16 b0fwwz,b0fzww,b0fwwh,b0fzzh,b0fww0
      complex*16 swwfer,szzfer,pggfer
*-
*-    constants
*-
      rhz2 = rhz**2
      rhw2 = rhw**2
*-
*-    scales
*-
      lnmuwm = log(rwm2/thmu2)
      lnmuzm = log(rzm2/thmu2)
      lnmuhm = log(rhm2/thmu2)
      lnctw  = lnmuwm-lnmuzm

*- calculation of \delta r in one-to-one with (6.390)-(6.395) of thebook
*-
      b0fwwz = dreal(b0f(-rwm2,thmu2,wm2,zm2))
      b0fwwh = dreal(b0f(-rwm2,thmu2,wm2,hm2))
      b0fzww = dreal(b0f(-rzm2,thmu2,wm2,wm2))
      b0fzzh = dreal(b0f(-rzm2,thmu2,zm2,hm2))
      b0fww0 = dreal(b0f(-rwm2,thmu2,wm2,cm2))
*-
      pg0fer = dreal(pggfer(0d0))
      drfer  = dreal(swwfer(rwm2)-szzfer(rzm2))/rwm2
      drwfer = dreal(swwfer(0d0) -swwfer(rwm2))/rwm2
*- formula (6.393)
*     drbos =(1d0/12d0/ctw4+4d0/3d0/ctw2-17d0/3d0-4d0*ctw2)
*    &      *(b0fwwz-ctw2*b0fzww)
*    &      +(1d0-1d0/3d0*rhw+1d0/12d0*rhw2)*b0fwwh
*    &      -(1d0-1d0/3d0*rhz+1d0/12d0*rhz2)/ctw2*b0fzzh
*    &      +1d0/12d0*stw2*rhw2*(lnrhw-1d0)
*    &      -1d0/12d0*(1d0/ctw4+6d0/ctw2-24d0+rhw)*lnctw
*    &      -1d0/12d0/ctw4-19d0/36d0/ctw2-133d0/18d0+8d0*ctw2
*- representation coded in ff_lib, both are numerically equal (gauge invariance)
      drbos = (1d0/12d0/ctw4+4d0/3d0/ctw2-17d0/3d0-4d0*ctw2)
     &     *(b0fwwz-ctw2*b0fzww)
     &     +(1d0-1d0/3d0*rhw+1d0/12d0*rhw2)*b0fwwh
     &     -(1d0-1d0/3d0*rhz+1d0/12d0*rhz2)/ctw2*b0fzzh-4d0*stw2*b0fww0
     &     -1d0/12d0*(-(1d0/ctw4+6d0/ctw2-24d0+rhw)*lnmuzm
     &     -rhw2*stw2*lnmuhm
     &     +(14d0+1d0/ctw2+16d0*ctw2-48d0*ctw4+rhw)*lnmuwm
     &     +1d0/ctw4+19d0/3d0/ctw2-22d0/3d0+stw2*rhw2)
*-
      drwbos = -(1d0/12d0/ctw4+4d0/3d0/ctw2-17d0/3d0-4d0*ctw2)*b0fwwz
     &     -(1d0-1d0/3d0*rhw+1d0/12d0*rhw2)*b0fwwh
     &     +3d0/4d0*rhw/(1d0-rhw)*(lnmuhm-lnmuwm)
     &     +1d0/4d0*rhw*(1d0-1d0/3d0*rhw)*lnmuhm
     &     +(1d0/4d0-3d0/stw2)*(lnmuwm-lnmuzm)
     &     -(1d0/12d0/ctw4+17d0/12d0/ctw2)*lnmuzm
     &     +(1d0/12d0/ctw2+11d0/2d0+1d0/12d0*rhw-4d0*stw2)*lnmuwm
     &     +1d0/12d0/ctw4+11d0/8d0/ctw2+139d0/36d0-177d0/24d0*ctw2
     &     +5d0/8d0*ctw4-1d0/12d0*rhw*(7d0/2d0-rhw)
*-
      deltar = (stw2*(-2d0/3-pg0fer)
     &     +ctw2/stw2*(drfer+drbos)+drwfer+drwbos
     &     +11d0/2-5d0/8*ctw2*(1d0+ctw2)+9d0/4d0*ctw2/stw2*lnctw
     &     +(3d0-7d0*ctw2)*lnmuwm)
      dr_bos = (stw2*(-2d0/3)
     &     +ctw2/stw2*drbos+drwbos
     &     +11d0/2-5d0/8*ctw2*(1d0+ctw2)+9d0/4d0*ctw2/stw2*lnctw
     &     +(3d0-7d0*ctw2)*lnmuwm)
      dr_fer = (stw2*(-pg0fer)+ctw2/stw2*drfer+drwfer)
*-
      return
      end


      subroutine fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier)
c  subroutine fourco calculates the integrals
c                    /t(n-3)
c    ress(i) =      !        s(x)*sin(alfa(i)*x) dx    and
c              t(4)/
c                    /t(n-3)
c    resc(i) =      !        s(x)*cos(alfa(i)*x) dx, i=1,...,m,
c              t(4)/
c  where s(x) denotes a cubic spline which is given in its
c  b-spline representation.
c
c  calling sequence:
c     call fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier)
c
c  input parameters:
c    t    : real array,length n, containing the knots of s(x).
c    n    : integer, containing the total number of knots. n>=10.
c    c    : real array,length n, containing the b-spline coefficients.
c    alfa : real array,length m, containing the parameters alfa(i).
c    m    : integer, specifying the number of integrals to be computed.
c    wrk1 : real array,length n. used as working space
c    wrk2 : real array,length n. used as working space
c
c  output parameters:
c    ress : real array,length m, containing the integrals ress(i).
c    resc : real array,length m, containing the integrals resc(i).
c    ier  : error flag:
c      ier=0 : normal return.
c      ier=10: invalid input data (see restrictions).
c
c  restrictions:
c    n >= 10
c    t(4) < t(5) < ... < t(n-4) < t(n-3).
c    t(1) <= t(2) <= t(3) <= t(4).
c    t(n-3) <= t(n-2) <= t(n-1) <= t(n).
c
c  other subroutines required: fpbfou,fpcsin
c
c  references :
c    dierckx p. : calculation of fouriercoefficients of discrete
c                 functions using cubic splines. j. computational
c                 and applied mathematics 3 (1977) 207-209.
c    dierckx p. : curve and surface fitting with splines, monographs on
c                 numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      integer n,m,ier
c  ..array arguments..
      real*8 t(n),c(n),wrk1(n),wrk2(n),alfa(m),ress(m),resc(m)
c  ..local scalars..
      integer i,j,n4
      real*8 rs,rc
c  ..
      n4 = n-4
c  before starting computations a data check is made. in the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(n.lt.10) go to 50
      j = n
      do 10 i=1,3
        if(t(i).gt.t(i+1)) go to 50
        if(t(j).lt.t(j-1)) go to 50
        j = j-1
  10  continue
      do 20 i=4,n4
        if(t(i).ge.t(i+1)) go to 50
  20  continue
      ier = 0
c  main loop for the different alfa(i).
      do 40 i=1,m
c  calculate the integrals
c    wrk1(j) = integral(nj,4(x)*sin(alfa*x))    and
c    wrk2(j) = integral(nj,4(x)*cos(alfa*x)),  j=1,2,...,n-4,
c  where nj,4(x) denotes the normalised cubic b-spline defined on the
c  knots t(j),t(j+1),...,t(j+4).
         call fpbfou(t,n,alfa(i),wrk1,wrk2)
c  calculate the integrals ress(i) and resc(i).
         rs = 0.
         rc = 0.
         do 30 j=1,n4
            rs = rs+c(j)*wrk1(j)
            rc = rc+c(j)*wrk2(j)
  30     continue
         ress(i) = rs
         resc(i) = rc
  40  continue
  50  return
      end


subroutine  STOMFS
  use simsphere_mod

!      INCLUDE 'modvars.h'

! The exponential function for solar radiation -- Albert Olioso

  fs = 1 / (1 - exp(-1/sc*sol))

  return
end