subroutine maxmem
use fdeclarations

implicit none

do i=1,z
hs(i)=max(high(i),good(i),moderate(i),poor(i),bad(i))
if (hs(i)>0) then

if (hs(i)==high(i)) then
aa(i,zz)=0.9
else if (hs(i)==good(i)) then
aa(i,zz)=0.7
else if (hs(i)==moderate(i)) then
aa(i,zz)=0.5
else if (hs(i)==poor(i)) then
aa(i,zz)=0.3
else
aa(i,zz)=0.1
end if

else
aa(i,zz)=aa(i-1,zz)
end if
end do

do i=1,z
if (l==1) then
suitability(i,zz)=aa(i,zz)
else if (l==2) then
s(i,zz)=aa(i,zz)
end if
end do

end subroutine maxmem


! NLSPMC Version 1.0 2/5/99
!----------------------------------------------------------------------
! This file contains two copies of subroutine named CCRINT and CCRIN1
! for use with double integration problems (e.g. integration over
! the polar angles in rigid limit EPR calculation programs)
!----------------------------------------------------------------------

!                    ======================
!                      subroutine CCRINT
!                    ======================

!  Clenshaw-Curtis-Romberg integration method according to algorithm
!  of O'Hara and Smith (Computer J. 12 (1969) 179-82)
!  Adapted from G. Bruno thesis, Cornell Univ. (see p. 554 Bruno thesis)
!  Code rearranged clarified, and re-commented by D. Budil, 1/16/90

!  The function to be integrated is supplied as a double precision
!  function whose name is passed to the program (external function f)

!   Parameters:
!       bndlow          Lower bound of integration
!       bndhi           Upper bound of integration
!       epsiln          Tolerance (absolute) for convergence of integral
!			Relative tolerance ratio is taken to be epsiln/100
!       small           Smallest permissible step, as fraction of (x range)/4

!   Returns:
!       neval           Number of function evaluations
!       id              Error flag (1 for normal, -1 for stack overflow)
!----------------------------------------------------------------------
    subroutine ccrint_new(bndlow,bndhi,epsiln,small,sum,neval,id,lr,kr,ipt,cpot,lptmx,kptmx)
!    external f

    integer :: id, neval, nstack
    double precision :: b1(30), b2(30), b3(30), b4(30), p(30)
    double precision :: bndlow, bndhi, acl7, ainsc, ccerr, &
    cnc1, cnc2, cnc3, cnc4, c7l1, c7l2, c7l3, c7l4, &
    c8r1, c8r2, c8r3, c8r4, &
    cvgtol, err, diff, h, hmin, rombrg, rt3, &
    sa, sc, sd, small, sum, &
    t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, epsiln, &
    x0, x1, x2, x3, x4, x5, x6, x7, x8, xx
    double precision :: dabs
    double precision :: ans, ans1

    integer :: ipt, lptmx,kptmx,lr,kr
    double precision cpot(5,5)
! ======================================================================
! Coefficients for 2*(5 point Newton-Cotes) integration
! 14/45, 28/45, 24/45, 64/45
! ======================================================================

    data cnc1 /0.3111111111111111d0 / &
    cnc2 /0.6222222222222222d0 / &
    cnc3 /0.5333333333333333d0 / &
    cnc4 /1.4222222222222222d0 /

! ======================================================================
! Coefficients for 8 point Romberg formula
! 868/2835, 1744/2835, 1408/2835, 4096/2835
! ======================================================================

    data c8r1 /0.3061728395061728d0 / &
    c8r2 /0.6151675485008818d0 / &
    c8r3 /0.4966490299823633d0 / &
    c8r4 /1.444797178130511d0  /

! ======================================================================
! Coefficients for 7 point Clenshaw-Curtis formula
! 36/315, 656/315, 576/315, 320/315
! ======================================================================

    data c7l1 /0.1142857142857143d0 / &
    c7l2 /2.082539682539683d0  / &
    c7l3 /1.828571428571429d0  / &
    c7l4 /1.015873015873016d0  /

    data rt3  /1.732050807568877d0 /

! ======================================================================
! Set initial domain to be the entire domain from lower to upper bound
! ======================================================================
    id = 1
    h  = (bndhi-bndlow)*0.25d0
    x0 = bndlow
    x2 = x0+h
    x4 = x2+h
    x6 = x4+h
    x8 = bndhi

!    write(*,*) 'started in ccrint_new, about to call fz'
    call fz(x0, lr,kr,lptmx,kptmx,cpot, ans)
!    write(*,*) 'started in ccrint_new, called fz'
    t0 = ans    !    t0 = f(x0)
    call fz(x2, lr,kr,lptmx,kptmx,cpot, ans)
    t2 = ans    !    t2 = f(x2)
    call fz(x4, lr,kr,lptmx,kptmx,cpot, ans)
    t4 = ans    !    t4 = f(x4)
    call fz(x6, lr,kr,lptmx,kptmx,cpot, ans)
    t6 = ans    !    t6 = f(x6)
    call fz(x8, lr,kr,lptmx,kptmx,cpot, ans)
    t8 = ans    !    t8 = f(x8)

    neval = 5

    err    = epsiln
    sum    = 0.0d0
    nstack = 0
    hmin   = small*h

! ======================================================================
! Beginning of an iteration: divide step size in half.
! (assumed that current domain is only a small fraction of the total)
! Supplied with a (sub)domain defined by the x values x0,x2,x4,x6,x8,
! interpolate the points x1, x3, x5, x7 and calculate f at these points
! ======================================================================

    4 h = 0.5d0*h
    if (dabs(h) <= dabs(hmin)) go to 9

    x1 = x0+h
    x3 = x2+h
    x5 = x4+h
    x7 = x6+h
!    write(*,*) 'in ccrint_new, about to call fz'
    call fz(x1, lr,kr,lptmx,kptmx,cpot, ans)
    t1 = ans    !    t0 = f(x1)
    call fz(x3, lr,kr,lptmx,kptmx,cpot, ans)
    t3 = ans    !    t3 = f(x3)
    call fz(x5, lr,kr,lptmx,kptmx,cpot, ans)
    t5 = ans    !    t5 = f(x5)
    call fz(x7, lr,kr,lptmx,kptmx,cpot, ans)
    t7 = ans    !    t7 = f(x7)

    neval=neval+4

    cvgtol = err*0.1D0
    if (nstack == 0) cvgtol = err

! ======================================================================
! First convergence test:
! Compare results of Newton-Cotes and Romberg quadratures.
! If absolute AND relative differences are too large, the current domain
! must be subdivided

! *** Modified 22-May-90: proceed if the integrated function is zero -DEB
! ======================================================================

    sa=t0+t8
    sc=t2+t6
    sd=t1+t3+t5+t7

    rombrg = (c8r1*sa + c8r2*t4 +c8r3*sc + c8r4*sd)*h
    ainsc  = (cnc1*sa + cnc2*t4 +cnc3*sc + cnc4*sd)*h
    diff    = dabs(rombrg-ainsc)

    if ( rombrg /= 0.0D0 .AND. ainsc /= 0.0D0) then
        if ( diff > cvgtol &
         .AND. diff/dabs( 0.5D0*(rombrg+ainsc) ) > cvgtol*1.0D-2 ) &
        go to 10
    endif

! ======================================================================
! Second convergence test:
! Compare 8 pt. Romberg with 7 pt. Clenshaw-Curtis quadratures.
! (Use error estimate for Clenshaw-Curtis quadrature if it is larger)
! If absolute AND relative differences are too large, the current domain
! needs to be subdivided

! *** Modified 22-May-90: proceed if the integrated function is zero -DEB
! ======================================================================

    xx  = rt3*h
    call fz(x2-xx, lr,kr,lptmx,kptmx,cpot, ans)
    call fz(x2+xx, lr,kr,lptmx,kptmx,cpot, ans1)
    t9 = ans + ans1 ! t9  = f(x2-xx) + f(x2+xx)
    call fz(x6-xx, lr,kr,lptmx,kptmx,cpot, ans)
    call fz(x6+xx, lr,kr,lptmx,kptmx,cpot, ans1)
    t10 = ans + ans1 ! t10 = f(x6-xx) + f(x6+xx)
    neval=neval+4
    acl7 = 0.5D0*h*(  c7l1*(sa+2.d0*t4) + c7l2*sc + c7l3*sd &
    + c7l4*(t9+t10) )
    diff  = dabs( acl7-rombrg )
    ccerr = (  dabs(0.5d0*(t0+t4)+t1+t3-t2-t9 ) &
    + dabs(0.5d0*(t4+t8)+t5+t7-t6-t10) )*h*64.d0/945.d0
    if ( ccerr > diff ) diff = ccerr

    if ( rombrg /= 0.0D0 .AND. acl7 /= 0.0D0) then
        if ( diff > cvgtol &
         .AND. diff/dabs(0.5d0*(acl7+rombrg)) > cvgtol/1.0D2) goto 10
    endif

! ======================================================================
! Convergence achieved for this subdomain: add integral into result
! Replace current subdomain with the top subdomain on the stack for next
! iteration (Integration is complete if the stack is empty)
! ======================================================================

    sum = sum + acl7

    if (diff < cvgtol) err = err + diff

    9 continue

    if (nstack <= 0) return

    h =  p(nstack)
    t0 = t8
    t2 = b1(nstack)
    t4 = b2(nstack)
    t6 = b3(nstack)
    t8 = b4(nstack)
    x0 = x8
    x2 = x0+h
    x4 = x2+h
    x6 = x4+h
    x8 = x6+h
    nstack = nstack-1
    go to 4

! ======================================================================
! Push upper half of current subdomain (points x5, x6, x7, x8)
! and function values onto the stack (error return if stack overflows)
! Replace current subdomain (points x0, x2, x4, x6, x8) and function values
! with its lower half (points x0, x1, x2, x3, x4) for next iteration
! ======================================================================

    10 nstack=nstack+1
    if(nstack > 30) then
        id=-1
        write(6,*)'CCRINT: more than 30 subdomain divisions'
        return
    endif

    b1(nstack) = t5
    b2(nstack) = t6
    b3(nstack) = t7
    b4(nstack) = t8
    p(nstack)  = h

    t8 = t4
    t6 = t3
    t4 = t2
    t2 = t1
    x8 = x4
    x6 = x3
    x4 = x2
    x2 = x1
    go to 4
    end subroutine ccrint_new


module IC

use parameters
use constants
use odes

implicit none

private backwards

public initial_conditions

contains

subroutine initial_conditions(alpha,beta,nu_obs,x,c)
!Arguments
!image plane coordinates
real(kind=dp),intent(in) :: alpha,beta,nu_obs
!coordinate vector
real(kind=dp), intent(out), dimension(6) :: x
!constants vector
real(kind=dp), intent(out), dimension(4) :: c

!Other

!Position/Velocity vector
real(kind=dp), dimension(6) :: PV_vector
real(kind=dp) :: r,theta,phi,rdot0, thetadot0,phidot0
!Time coordinate
real(kind=dp) :: t
!momenta
real(kind=dp) :: sig,del, pr, ptheta
!energy
real(kind=dp) :: s1,E2,En, Eprime, Eobs
!Angular momentum
real(kind=dp) :: Lz
!Constant kappa
real(kind=dp) :: kappa
!Plasma frequency, number density terms (f,g) and derivatives (f1,g1)
real(kind=dp) :: omega2, f,g,f1,g1
real(kind=dp) :: B2

if (IntegrationType .EQ. 'Backwards') then

    call backwards(alpha, beta, PV_vector)

else if (IntegrationType .EQ. 'Forwards') then

    call forwards(PV_vector)

endif

!Etract info from vector
r = PV_vector(1) ; theta = PV_vector(2) ; phi = PV_vector(3)
rdot0 = PV_vector(4) ; thetadot0 = PV_vector(5) ; phidot0 = PV_vector(6)

!Define some useful quantitites
sig = r**2.0_dp +(a*cos(theta))**2.0_dp
del = r**2.0_dp - 2.0_dp*r +a**2

!Time coord
t=0.0_dp

!Plasma
B2= 4.0_dp*PI*electron_charge**2 *N0 / electron_mass
call density_profile(r,theta,f,g,f1,g1)
omega2 = B2 *(f+g) / sig

!Calculate ray velocity magnitude
s1 = sig-2.0*r
Eobs = 2.0_dp*PI*nu_obs*1e9
!Eobs = 1.0_dp
Eprime = sqrt( (Eobs**2 - omega2 + 2.0_dp*r*omega2/sig) / (s1*(rdot0**2 /del + thetadot0**2) + del*sin(theta)**2*phidot0**2) )

!... and correct velocity components
rdot0 = rdot0 * Eprime ; thetadot0 = thetadot0 * Eprime ; phidot0 = phidot0 * Eprime

!...and double check the derived energy matches the one you want
E2 = s1*(rdot0**2.0/del +thetadot0**2.0 +omega2/sig) + del*sin(theta)**2.0*phidot0**2.0
En  = sqrt(E2)
!print *, En
!print *, Eobs

!Momenta
pr = rdot0 *sig/del
ptheta = sig*thetadot0

!Angular momentum
Lz = ((sig*del*phidot0 - 2.0*a*r*En) * sin(theta)**2.0/s1)

!Normalize to E=1
pr = pr/Eobs
ptheta = ptheta/Eobs
Lz = Lz/Eobs
B2 = B2 / Eobs**2

!One more constant to define
kappa = ptheta**2.0 + a**2*sin(theta)**2.0 + Lz**2.0/sin(theta)**2.0

!Save to vectors for output
x(1) = r
x(2) = theta
x(3) = phi
x(4) = t
x(5) = pr
x(6) = ptheta

c(1) = Lz
c(2) = kappa
c(3) = 1.0e-6 !initial stepsize
c(4) = B2

!Write stuff to global
Eobs_global = Eobs

end subroutine initial_conditions

subroutine backwards(alpha,beta,PV)
!Arguments
real(kind=dp), intent(in) :: alpha,beta
real(kind=dp), intent(out),dimension(6) :: PV
!Other

!Cartesian coords
real(kind=dp) :: xprime, yprime, zprime

!BL coords
real(kind=dp) :: w,r,theta,phi

!derivative
real(kind=dp) :: sig,u,zdot,v,rdot0,thetadot0,phidot0,del

!Covert to primed Cartesian frame
xprime = sqrt(r_obs**2.0_dp +a**2) * sin(theta_obs) - beta*cos(theta_obs)
yprime = alpha
zprime = r_obs*cos(theta_obs) + beta*sin(theta_obs)

! Boyer-Lindquist
w = xprime**2.0_dp +yprime**2.0_dp +zprime **2.0_dp - a**2
r = sqrt((w+sqrt(w**2.0+4.0*a**2*zprime**2.0_dp))/2.0_dp)
theta = acos(zprime/r)
phi = atan2(yprime,xprime)

!Derivatives
sig = r**2.0_dp +(a*cos(theta))**2.0_dp
del = r**2.0_dp - 2.0_dp*r +a**2
u = sqrt(r**2.0_dp+a**2)
zdot = -1.0_dp
v= -sin(theta_obs)*cos(phi)

rdot0 = -zdot*(-u**2.0*cos(theta_obs)*cos(theta)+r*u*v*sin(theta))/sig
thetadot0 = -zdot*(cos(theta_obs)*r*sin(theta)+u*v*cos(theta))/sig
phidot0 = -zdot*sin(theta_obs)*sin(phi)/(u*sin(theta))

!write for output
PV(1) = r ;PV(2) = theta ;PV(3) = phi
PV(4) = rdot0 ;PV(5) = thetadot0 ;PV(6) = phidot0

end subroutine backwards

subroutine forwards(PV)
!Arguments
real(kind=dp), intent(out),dimension(6) :: PV

!Other
real(kind=dp) :: r,theta,phi
real(kind=dp) :: xdot, ydot, zdot
real(kind=dp) :: rdot0, thetadot0, phidot0
real(kind=dp) :: mm, sigma

!Load initial position from parameters file
r= r_init ; theta = theta_init ; phi = phi_init

!Cartesian direction of ray from angles in parameters.f
xdot = sin(dir_theta)*cos(dir_phi)
ydot = sin(dir_theta)*sin(dir_phi)
zdot = cos(dir_theta)

!Convert to BL
sigma = r**2.0_dp +(a*cos(theta))**2.0_dp
mm = sqrt(r**2 + a**2)
rdot0 = mm*r*sin(theta)*cos(phi)*xdot/sigma &
       +mm*r*sin(theta)*sin(phi)*ydot/sigma &
       +mm**2*cos(theta)*zdot/sigma

thetadot0 = (mm*cos(theta)*cos(phi) * xdot &
           +mm*cos(theta)*sin(phi) * ydot &
           -r*sin(theta)* zdot&
           )/sigma

phidot0 = (-sin(phi)*xdot + cos(phi)*ydot)/(mm*sin(theta))

print *, xdot,ydot,zdot
print *, r,theta,phi
print *, rdot0,thetadot0,phidot0

!write for output
PV(1) = r ;PV(2) = theta ;PV(3) = phi
PV(4) = rdot0 ;PV(5) = thetadot0 ;PV(6) = phidot0

end subroutine forwards

end module IC


c
c     testing code for FMM - tests charges and dipoles against
c     O(N^2) direct method
c
c
        implicit real *8 (a-h,o-z)
        real *8 source(2,2 000 000)
        complex *16 charge(2 000 000)
        complex *16 dip1(2 000 000)
        complex *16 dip2(2 000 000)
        complex *16 vel(2 000 000)
        complex *16 grada(2 000 000)
        complex *16 gradaa(2 000 000)
c
        complex *16 vel2(2 000 000)
        complex *16 grada2(2 000 000)
        complex *16 gradaa2(2 000 000)
c
        real *8 target(2,2 000 000)
        complex *16 veltarg(2 000 000)
        complex *16 gradatarg(2 000 000)
        complex *16 gradaatarg(2 000 000)
c
        complex *16 vtemp,gatemp,gaatemp
c
        complex *16 ima
        data ima/(0.0d0,1.0d0)/
c
        done=1
        pi=4*atan(done)
c
c       SET ALL PARAMETERS
c
        call prini(6,13)

        print *, 'ENTER n'
        read *, nsource

        call prinf('ierr=*',ierr,1)
c
        call prinf('nsource=*',nsource,1)
c
c       ... construct randomly located charge distribution on a unit circle
        done=1
        pi=4*atan(done)
c
        d=hkrand(0)
        do i=1,nsource
           phi=hkrand(0)*2*pi
           source(1,i)=cos(phi)
           source(2,i)=sin(phi)
        enddo
c
c       ... construct target distribution on a unit circle
c
        ntarget=nsource*1
        do i=1,ntarget
           phi=hkrand(0)*2*pi
           target(1,i)=cos(phi)+3.0d0
           target(2,i)=sin(phi)
        enddo
c
        call prinf('ntarget=*',ntarget,1)
c
        scale=1
        do i=1,nsource
           source(1,i)=source(1,i)*scale
           source(2,i)=source(2,i)*scale
        enddo
        do i=1,ntarget
           target(1,i)=target(1,i)*scale
           target(2,i)=target(2,i)*scale
        enddo

        iprec=4
        call prinf('iprec=*',iprec,1)
c
        ifvel=1
        ifgrada=1
c
        ifcharge=1
        ifdipole=1
c
        ifveltarg=1
        ifgradatarg=1
c
        ifgradaa=1
        ifgradaatarg=1
c
        if( ifveltarg .eq. 0 .and. ifgradatarg .eq. 0
     $     .and. ifgradaatarg .eq. 0 ) ntarget = 0
c
        if (ifcharge .eq. 1 ) then
           do i=1,nsource
              charge(i)=1.0d0/i
           enddo
        endif
c
        if (ifdipole .eq. 1) then
           do i=1,nsource
              dip1(i)=1/i+ima/(2*i)
              dip2(i)=1/i-ima/(2*i)
           enddo
        endif
c
        t1=second()
C$        t1=omp_get_wtime()
c
        call bhfmm2dparttarg(ier,iprec,
     $     nsource,source,
     $     ifcharge,charge,ifdipole,dip1,dip2,
     $     ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $     ntarget,target,ifveltarg,veltarg,ifgradatarg,gradatarg,
     $     ifgradaatarg,gradaatarg)
        t2=second()
C$        t2=omp_get_wtime()

c
c
        call prinf('nsource=*',nsource,1)
        call prinf('ntarget=*',ntarget,1)
        call prin2('after fmm, time (sec)=*',t2-t1,1)
        call prin2('after fmm, speed (points+targets/sec)=*',
     $     (nsource+ntarget)/(t2-t1),1)

        m=min(nsource,12)
c
        ifprint=0
        if (ifprint .eq. 1) then
           call prin2('source=*',source,3*nsource)
        endif
c
        do i=1,nsource
           if (ifvel.eq.1) vel2(i)=0
           if (ifgrada.eq.1) then
              grada2(i)=0
           endif
           if (ifgradaa.eq. 1) then
              gradaa2(i)=0
           endif
        enddo
        t1=second()
C$      t1=omp_get_wtime()
c
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(i,j,vtemp,gatemp,gaatemp)
cccC$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(4)
        do 7160 j=1,m
           do 7150 i=1,nsource
              if( i .eq. j ) goto 7150
              call bh2ddireval(source(1,i),1,ifcharge,charge(i),
     1        ifdipole,dip1(i),dip2(i),source(1,j),vtemp,ifgrada,
     2        gatemp,ifgradaa,gaatemp)
              if (ifvel .eq. 1) vel2(j)=vel2(j)+vtemp
              if (ifgrada .eq. 1) then
                 grada2(j)=grada2(j)+gatemp
              endif
              if (ifgradaa .eq. 1) then
                 gradaa2(j)=gradaa2(j)+gaatemp
              endif
 7150      continue
 7160   continue
C$OMP END PARALLEL DO
        t2=second()
C$      t2=omp_get_wtime()
        ifprint = 1
        if (ifprint .eq. 1) then
           if( ifvel.eq.1 ) then
              call prin2('fmm, vel=*',vel,2*m)
              call prin2('directly, vel=*',vel2,2*m)
           endif

           if( ifgrada.eq.1 ) then
              call prin2('fmm, grada=*',grada,2*m)
              call prin2('directly, grada=*',grada2,2*m)
           endif

           if( ifgradaa.eq.1 ) then
              call prin2('fmm, gradaa=*',gradaa,2*m)
              call prin2('directly, gradaa=*',gradaa2,2*m)
           endif
        endif
c
        call prin2('directly, estimated time (sec)=*',
     $     (t2-t1)*dble(nsource)/dble(m),1)
        call prin2('directly, estimated speed (points/sec)=*',
     $     m/(t2-t1),1)
c
c        open(unit=1,file='output.dat',access='append')
c        write(1,*) "ns =",nsource

        if (ifvel .eq. 1)  then
           call l2derror(vel,vel2,m,aerr,rerr)
           call prin2('relative L2 error in potential=*',rerr,1)
c           write(1,*) "err vel =",rerr
           call l2derror2(vel,vel2,m,aerr,rerr)
           call prin2('relative L2 error in re(potential)=*',rerr,1)
c           write(1,*) "err Re(vel)=",rerr
        endif
c
        if (ifgrada.eq. 1) then
           call l2derror(grada,grada2,m,aerr,rerr)
           call prin2('relative L2 error in gradient=*',rerr,1)
c           write(1,*) "err grada=",rerr
        endif
c
        if (ifgradaa.eq. 1) then
           call l2derror(gradaa,gradaa2,m,aerr,rerr)
           call prin2('relative L2 error in hessian=*',rerr,1)
c           write(1,*) "err gradaa=",rerr
        endif
c
c
        if( ntarget .eq. 0 ) stop
c
        do i=1,ntarget
           if (ifveltarg .eq. 1) vel2(i)=0
           if (ifgradatarg .eq. 1) then
              grada2(i)=0
           endif
           if (ifgradaatarg .eq. 1) then
              gradaa2(i)=0
           endif
        enddo
        t1=second()
C$      t1=omp_get_wtime()
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(i,j,vtemp,gatemp,gaatemp)
cccC$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(4)
        do 8160 j=1,m
           do 8150 i=1,nsource
              call bh2ddireval(source(1,i),1,ifcharge,charge(i),
     1        ifdipole,dip1(i),dip2(i),target(1,j),vtemp,
     2        ifgradatarg,gatemp,ifgradaatarg,gaatemp)
              if (ifveltarg .eq. 1) vel2(j)=vel2(j)+vtemp
              if (ifgradatarg .eq. 1) then
                 grada2(j)=grada2(j)+gatemp
              endif
              if (ifgradaatarg .eq. 1) then
                 gradaa2(j)=gradaa2(j)+gaatemp
              endif
 8150      continue
 8160   continue
C$OMP END PARALLEL DO
        t2=second()
C$      t2=omp_get_wtime()
c
        if (ifprint .eq. 1) then
           if (ifveltarg .eq. 1)
     $        call prin2('after fmm, veltarg=*',veltarg,2*m)
           if (ifveltarg .eq. 1)
     $        call prin2('directly, veltarg=*',vel2,2*m)
           if( ifgradatarg.eq.1 )
     $        call prin2('after fmm, gradatarg=*',gradatarg,2*m)
           if( ifgradatarg.eq.1 )
     $        call prin2('directly, gradatarg=*',grada2,2*m)
           if( ifgradaatarg.eq.1 )
     $        call prin2('after fmm, gradaatarg=*',gradaatarg,2*m)
           if( ifgradaatarg.eq.1 )
     $        call prin2('directly, gradaatarg=*',gradaa2,2*m)
        endif
c
        call prin2('directly, estimated time (sec)=*',
     $     (t2-t1)*dble(ntarget)/dble(m),1)
        call prin2('directly, estimated speed (targets/sec)=*',
     $     m/(t2-t1),1)
c
        if (ifveltarg .eq. 1) then
           call l2derror(veltarg,vel2,m,aerr,rerr)
           call prin2('relative L2 error in target velocity=*',rerr,1)
c           write(1,*) "err vel targ=",rerr
           call l2derror2(veltarg,vel2,m,aerr,rerr)
           call prin2
     $     ('relative L2 error in target re(velocity)=*',rerr,1)
c           write(1,*) "err Re(vel) targ=",rerr
        endif
c
        if (ifgradatarg .eq. 1) then
           call l2derror(gradatarg,grada2,m,aerr,rerr)
           call prin2('relative L2 error in target gradient=*',rerr,1)
c           write(1,*) "err grada targ=",rerr
        endif
c
        if (ifgradaatarg .eq. 1) then
           call l2derror(gradaatarg,gradaa2,m,aerr,rerr)
           call prin2('relative L2 error in target hessian=*',rerr,1)
c           write(1,*) "err gradaa targ=",rerr
        endif
c        write(1,*) ""
c        write(1,*) ""
c        close(1)
c
        stop
        end
c
c
c
        subroutine l2dmperr(mpole1,mpole2,nterms,d)
        implicit real *8 (a-h,o-z)
c
        complex *16 mpole1(-nterms:nterms)
        complex *16 mpole2(-nterms:nterms)
c
        d=0
c
        do n=-nterms,nterms
        d=d+abs(mpole1(n)-mpole2(n))**2
        enddo
c
        d=d/(2*nterms+1)
        d=sqrt(d)
c
        return
        end
c
c
c
c
c
        subroutine l2dmpnorm(mpole,nterms,d)
        implicit real *8 (a-h,o-z)
c
        complex *16 mpole(-nterms:nterms)
c
        d=0
c
        do n=-nterms,nterms
        d=d+abs(mpole(n))**2
        enddo
c
        d=d/(2*nterms+1)
        d=sqrt(d)
c
        return
        end
c
c
c
c
c
        subroutine l2derror(pot1,pot2,n,ae,re)
        implicit real *8 (a-h,o-z)
c
c       evaluate absolute and relative errors
c
        complex *16 pot1(n),pot2(n)
c
        d=0
        a=0
c
        do i=1,n
        d=d+abs(pot1(i)-pot2(i))**2
        a=a+abs(pot1(i))**2
        enddo
c
        d=d/n
        d=sqrt(d)
        a=a/n
        a=sqrt(a)
c
        ae=d
        re=d/a
c
        return
        end
c
c
c
c
c
        subroutine l2derror2(pot1,pot2,n,ae,re)
        implicit real *8 (a-h,o-z)
c
c       evaluate absolute and relative errors of the real part
c
        complex *16 pot1(n),pot2(n)
c
        d=0
        a=0
c
        do i=1,n
        d=d+dble(pot1(i)-pot2(i))**2
        a=a+dble(pot1(i))**2
        enddo
c
        d=d/n
        d=sqrt(d)
        a=a/n
        a=sqrt(a)
c
        ae=d
        re=d/a
c
        return
        end
c
c
c


c     Using guru interface from fortran for 1D type 1 transforms,
c     a math test of one output, and how to change from default options.
c     Single-precision only.
c     Legacy-style: f77, plus dynamic allocation & derived types from f90.

c     To compile (linux/GCC) from this directory, use eg (paste to one line):

c     gfortran -fopenmp -I../../include -I/usr/include guru1d1f.f
c     -L../../lib -lfinufftf -o guru1d1f

c     Alex Barnett and Libin Lu 5/29/20. Ptr fixes 10/6/21

      program guru1d1f
      implicit none

c     our fortran-header, always needed
      include 'finufft.fh'
c     if you want to use FFTW's modes by name...
      include 'fftw3.f'

c     note some inputs are int (int*4) but others BIGINT (int*8)
      integer ier,iflag
      integer*8 N,ktest,M,j,k,ktestindex,t1,t2,crate
      real*4, allocatable :: xj(:)
      real*4 err,tol,pi,t,fmax
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*8, allocatable :: cj(:),fk(:)
      complex*8 fktest
      integer*8, allocatable :: n_modes(:)
      integer ttype,dim,ntrans
c     to pass null pointers to unused arguments...
      real*4, pointer :: dummy => null()

c     this is what you use as the "opaque" ptr to ptr to finufft_plan...
      integer*8 plan
c     this is how you create the options struct in fortran...
      type(nufft_opts) opts
c     or this is if you want default opts, make a null pointer...
      type(nufft_opts), pointer :: defopts => null()

c     how many nonuniform pts
      M = 200000
c     how many modes (not too much since FFTW_MEASURE slow later)
      N = 100000

      allocate(fk(N))
      allocate(xj(M))
      allocate(cj(M))
      print *,''
      print *,'creating data then run guru interface, default opts...'
c     create some quasi-random NU pts in [-pi,pi], complex strengths
      do j = 1,M
         xj(j) = pi * cos(pi*j/M)
         cj(j) = cmplx( sin((100e0*j)/M), cos(1.0+(50e0*j)/M))
      enddo

c     ---- SIMPLEST GURU DEMO WITH DEFAULT OPTS (as in simple1d1) ---------
c     mandatory parameters to FINUFFT guru interface...
      ttype = 1
      dim = 1
      ntrans = 1
      iflag = 1
      tol = 1e-5
      allocate(n_modes(3))
      n_modes(1) = N
c     (note since dim=1, unused entries on n_modes are never read)
      call system_clock(t1)
c     use default options
      call finufftf_makeplan(ttype,dim,n_modes,iflag,ntrans,
     $     tol,plan,defopts,ier)
c     note for type 1 or 2, arguments 6-9 ignored...
      call finufftf_setpts(plan,M,xj,dummy,dummy,dummy,dummy,dummy,
     $     dummy,dummy,dummy,dummy,dummy,ier)
c     Do it: reads cj (strengths), writes fk (mode coeffs) and ier (status)
      call finufftf_execute(plan,cj,fk,ier)
      call system_clock(t2,crate)
      t = (t2-t1)/float(crate)
      if (ier.eq.0) then
         print '("done in ",f6.3," sec, ",e10.2" NU pts/s")',t,M/t
      else
         print *,'failed! ier=',ier
      endif
      call finufftf_destroy(plan,ier)

c     math test: single output mode with given freq (not array index) k
      ktest = N/3
      fktest = cmplx(0,0)
      do j=1,M
         fktest = fktest + cj(j) * cmplx( cos(ktest*xj(j)),
     $        sin(iflag*ktest*xj(j)) )
      enddo
c     compute inf norm of fk coeffs for use in rel err
      fmax = 0
      do k=1,N
         fmax = max(fmax,cabs(fk(k)))
      enddo
      ktestindex = ktest + N/2 + 1
      print '("rel err for mode k=",i10," is ",e10.2)',ktest,
     $     cabs(fk(ktestindex)-fktest)/fmax

c     ----------- GURU DEMO WITH NEW OPTIONS, MULTIPLE EXECS ----------
      print *,''
      print *, 'setting new options, rerun guru interface...'
      call finufftf_default_opts(opts)
c     refer to fftw3.f to set various FFTW plan modes...
      opts%fftw = FFTW_ESTIMATE_PATIENT
      opts%debug = 1
c     note you need a fresh plan if change opts
      call finufftf_makeplan(ttype,dim,n_modes,iflag,ntrans,
     $     tol,plan,opts,ier)
      call finufftf_setpts(plan,M,xj,dummy,dummy,dummy,dummy,dummy,
     $     dummy,dummy,dummy,dummy,dummy,ier)
c     Do it: reads cj (strengths), writes fk (mode coeffs) and ier (status)
      call finufftf_execute(plan,cj,fk,ier)
c     change the strengths
      do j = 1,M
         cj(j) = cmplx( sin((10e0*j)/M), cos(2.0+(20e0*j)/M))
      enddo
c     do another transform using same NU pts
      call finufftf_execute(plan,cj,fk,ier)
c     change the NU pts then do another transform w/ existing strengths...
      do j = 1,M
         xj(j) = pi/2.0 * cos(pi*j/M)
      enddo
      call finufftf_setpts(plan,M,xj,dummy,dummy,dummy,dummy,dummy,
     $     dummy,dummy,dummy,dummy,dummy,ier)
      call finufftf_execute(plan,cj,fk,ier)
      if (ier.eq.0) then
         print *,'done.'
      else
         print *,'failed! ier=',ier
      endif
      call finufftf_destroy(plan,ier)

      stop
      end


c !DEC$ IF .NOT.DEFINED (SUNOS) .AND. .NOT.DEFINED(OSF1) .AND. .NOT.DEFINED(CRAY)
      SUBROUTINE sgesv (N, NRHS, A, LDA, IPIV, B, LDB, INFO)
      USE LAPREC, ONLY: WP => SP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER :: INFO, LDA, LDB, N, NRHS
      INTEGER :: IPIV(N)
      REAL(WP) :: A(LDA, N), B(LDB, NRHS)
*  purpose
*  =======
*
*  sgesv computes the solution to a real system of linear equations
*     a * x = b,
*  where a is an n-by-n matrix and x and b are n-by-nrhs matrices.
*
*  the lu decomposition with partial pivoting and row interchanges is
*  used to factor a as
*     a = p * l * u,
*  where p is a permutation matrix, l is unit lower triangular, and u is
*  upper triangular.  the factored form of a is then used to solve the
*  system of equations a * x = b.
*
*  arguments
*  =========
*
*  n       (input) integer
*          the number of linear equations, i.e., the order of the
*          matrix a.  n >= 0.
*
*  nrhs    (input) integer
*          the number of right hand sides, i.e., the number of columns
*          of the matrix b.  nrhs >= 0.
*
*  a       (input/output) real array, dimension (lda,n)
*          on entry, the n-by-n coefficient matrix a.
*          on exit, the factors l and u from the factorization
*          a = p*l*u; the unit diagonal elements of l are not stored.
*
*  lda     (input) integer
*          the leading dimension of the array a.  lda >= max(1,n).
*
*  ipiv    (output) integer array, dimension (n)
*          the pivot indices that define the permutation matrix p;
*          row i of the matrix was interchanged with row ipiv(i).
*
*  b       (input/output) real array, dimension (ldb,nrhs)
*          on entry, the n-by-nrhs matrix of right hand side matrix b.
*          on exit, if info = 0, the n-by-nrhs solution matrix x.
*
*  ldb     (input) integer
*          the leading dimension of the array b.  ldb >= max(1,n).
*
*  info    (output) integer
*          = 0:  successful exit
*          < 0:  if info = -i, the i-th argument had an illegal value
*          > 0:  if info = i, u(i,i) is exactly zero.  the factorization
*                has been completed, but the factor u is exactly
*                singular, so the solution could not be computed.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           sgetrf, sgetrs, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL xerbla( 'SGESV ', -INFO )
         RETURN
      END IF
*
*     Compute the LU factorization of A.
*
      CALL sgetrf( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL sgetrs( 'No TRANSPOSE', N, NRHS, A, LDA, IPIV, B, LDB,
     $                INFO )
      END IF

      END SUBROUTINE sgesv

      SUBROUTINE dgesv (N, NRHS, A, LDA, IPIV, B, LDB, INFO)
      USE LAPREC, ONLY: WP => DP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER :: INFO, LDA, LDB, N, NRHS
      INTEGER :: IPIV(N)
      REAL(WP) :: A(LDA, N), B(LDB, NRHS)
*  purpose
*  =======
*
*  dgesv computes the solution to a real system of linear equations
*     a * x = b,
*  where a is an n-by-n matrix and x and b are n-by-nrhs matrices.
*
*  the lu decomposition with partial pivoting and row interchanges is
*  used to factor a as
*     a = p * l * u,
*  where p is a permutation matrix, l is unit lower triangular, and u is
*  upper triangular.  the factored form of a is then used to solve the
*  system of equations a * x = b.
*
*  arguments
*  =========
*
*  n       (input) integer
*          the number of linear equations, i.e., the order of the
*          matrix a.  n >= 0.
*
*  nrhs    (input) integer
*          the number of right hand sides, i.e., the number of columns
*          of the matrix b.  nrhs >= 0.
*
*  a       (input/output) real array, dimension (lda,n)
*          on entry, the n-by-n coefficient matrix a.
*          on exit, the factors l and u from the factorization
*          a = p*l*u; the unit diagonal elements of l are not stored.
*
*  lda     (input) integer
*          the leading dimension of the array a.  lda >= max(1,n).
*
*  ipiv    (output) integer array, dimension (n)
*          the pivot indices that define the permutation matrix p;
*          row i of the matrix was interchanged with row ipiv(i).
*
*  b       (input/output) real array, dimension (ldb,nrhs)
*          on entry, the n-by-nrhs matrix of right hand side matrix b.
*          on exit, if info = 0, the n-by-nrhs solution matrix x.
*
*  ldb     (input) integer
*          the leading dimension of the array b.  ldb >= max(1,n).
*
*  info    (output) integer
*          = 0:  successful exit
*          < 0:  if info = -i, the i-th argument had an illegal value
*          > 0:  if info = i, u(i,i) is exactly zero.  the factorization
*                has been completed, but the factor u is exactly
*                singular, so the solution could not be computed.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           dgetrf, dgetrs, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL xerbla( 'dgeSV ', -INFO )
         RETURN
      END IF
*
*     Compute the LU factorization of A.
*
      CALL dgetrf( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL dgetrs( 'No TRANSPOSE', N, NRHS, A, LDA, IPIV, B, LDB,
     $                INFO )
      END IF

      END SUBROUTINE dgesv
c !DEC$ ELSE
c       SUBROUTINE la_stub
c       END SUBROUTINE la_stub
c !DEC$ ENDIF


! =========================================================================================
! This module contains physical quantities.
!
! Note: We cannot use the keyword "parameter" since we read in the values
!       of the quantities from the NetCDF file. Hence, they are not known
!       at compile-time which is required for "parameter variables". However,
!       the keyword "protected" (Fortran2003) allows to make the quantities
!       non-modifiable outside the module (14 March 2022,
!       https://stackoverflow.com/questions/15020460/protected-global-variables-in-fortran)
!
! References:
!   American Meteorological Society, 2022: Standard gravity. Glossary of Meteorology,
!   https://glossary.ametsoc.org/wiki/Standard_gravity
!
!   American Meteorological Society, 2022: Latent heat. Glossary of Meteorology,
!   https://glossary.ametsoc.org/wiki/Latent_heat
!
!   American Meteorological Society, 2022: Specific heat capacity. Glossary of Meteorology,
!   https://glossary.ametsoc.org/wiki/Specific_heat_capacity
!
!   American Meteorological Society, 2022: Standard atmosphere. Glossary of Meteorology,
!   https://glossary.ametsoc.org/wiki/Standard_atmosphere
!
!   American Meteorological Society, 2022: Angular velocity of the earth. Glossary of Meteorology,
!   https://glossary.ametsoc.org/wiki/Angular_velocity_of_the_earth
!
!   Dritschel D.G., Böing S.J., Parker D.J., Blyth A.M.
!   The moist parcel-in-cell method for modelling moist convection.
!   Q J R Meteorol Soc. 2018; 144:1695–1718. https://doi.org/10.1002/qj.3319
!
!   Böing S.J., Dritschel D.G., Parker D.J., Blyth, A.M.
!   Comparison of the Moist Parcel-in-Cell (MPIC) model with large-eddy
!   simulation for an idealized cloud.
!   Q J R Meteorol Soc. 2019; 145: 1865– 1881. https://doi.org/10.1002/qj.3532
! =========================================================================================
module physics
    use constants
    use netcdf_reader
    use netcdf_utils
    use netcdf_writer
    use iso_fortran_env, only : IOSTAT_END
    implicit none

    ![m/s**2] standard gravity (i.e. at 45° latitude and mean sea level):
    double precision, protected :: gravity = 9.80616d0

    ![J/kg] latent heat of vaporization:
    double precision, protected :: L_v = 2.501e6

    ![J/(kg*K)] specific heat at constant pressure and dry air:
    double precision, protected :: c_p = 1005.7d0

    ![K] temperature at zero pressure altitude (15°C)
    double precision, protected :: theta_0 = 288.15d0

    ![rad/s] default value: angular velocity of the earth
    double precision :: ang_vel = 0.000072921d0

    logical, protected  :: l_planet_vorticity = .false.

    ![°] latitude angle (45° corresponds to standard gravity)
    double precision, protected  :: lat_degrees = 45.0d0

    ![1] MPIC specific: saturation specific humidity at ground level
    double precision, protected  :: q_0 = 0.015d0

    ![m] MPIC specific, scale-height, H
    double precision, protected :: height_c = 1000.0d0

    !
    ! The following quantities are calculated:
    !

    double precision, protected :: lat_ref

    ![1/m] MPIC specific, inverse scale-height
    double precision, protected :: lambda_c

    ! MPIC specific, see equation (5) of MPIC paper
    double precision, protected :: glat

    ! MPIC specific
    double precision, protected :: glati

    ! planetary vorticity (all three components)
    double precision, protected :: f_cor(3)

    interface print_physical_quantity
        module procedure :: print_physical_quantity_double
        module procedure :: print_physical_quantity_integer
        module procedure :: print_physical_quantity_logical
        module procedure :: print_physical_quantity_character
    end interface print_physical_quantity

    private :: update_physical_quantities,          &
               print_physical_quantity_double,      &
               print_physical_quantity_integer,     &
               print_physical_quantity_logical,     &
               print_physical_quantity_character

    contains

        ! This subroutine is only used in model setups
        subroutine read_physical_quantities_from_namelist(fname)
            character(*), intent(in) :: fname
            integer                  :: ios
            integer                  :: fn = 2
            logical                  :: exists = .false.

            ! namelist definitions
            namelist /PHYSICS/ gravity,             &
                               L_v,                 &
                               c_p,                 &
                               theta_0,             &
                               ang_vel,             &
                               l_planet_vorticity,  &
                               lat_degrees,         &
                               q_0,                 &
                               height_c

            ! check whether file exists
            inquire(file=fname, exist=exists)

            if (exists .eqv. .false.) then
                print *, 'Error: input file "' // fname // '" does not exist.'
                stop
            endif

            ! open and read Namelist file.
            open(action='read', file=fname, iostat=ios, newunit=fn)

            read(nml=PHYSICS, iostat=ios, unit=fn)

            if (ios == IOSTAT_END) then
                ! physical constants/parameters not present
            else if (ios /= 0) then
                print *, 'Error: invalid Namelist format.'
                stop
            endif

            close(fn)

            call update_physical_quantities

        end subroutine read_physical_quantities_from_namelist

        subroutine update_physical_quantities

            glat = gravity * L_v / (c_p * theta_0)
            glati = one / glat

            lambda_c = one / height_c

            if (l_planet_vorticity) then
                lat_ref = lat_degrees * deg2rad
                f_cor(1) = zero
                f_cor(2) = two * ang_vel * dcos(lat_ref)
                f_cor(3) = two * ang_vel * dsin(lat_ref)
            else
                f_cor = zero
            endif
        end subroutine update_physical_quantities

        subroutine read_physical_quantities(ncid)
            integer, intent(in) :: ncid
            integer             :: grp_ncid

            ncerr = nf90_inq_ncid(ncid, 'physical_quantities', grp_ncid)

            if (ncerr == 0) then
                call read_netcdf_attribute_default(grp_ncid, 'standard_gravity', gravity)
                call read_netcdf_attribute_default(grp_ncid, 'latent_heat_of_vaporization', L_v)
                call read_netcdf_attribute_default(grp_ncid, 'specific_heat', c_p)
                call read_netcdf_attribute_default(grp_ncid, 'temperature_at_sea_level', theta_0)
                call read_netcdf_attribute_default(grp_ncid, 'planetary_angular_velocity', ang_vel)
                call read_netcdf_attribute_default(grp_ncid, 'saturation_specific_humidity_at_ground_level', q_0)
                call read_netcdf_attribute_default(grp_ncid, 'planetary_vorticity', l_planet_vorticity)
                call read_netcdf_attribute_default(grp_ncid, 'latitude_degrees', lat_degrees)
                call read_netcdf_attribute_default(grp_ncid, 'scale_height', height_c)
#ifdef ENABLE_VERBOSE
            else
                print *, "WARNING: No physical constants found! EPIC uses default values."
#endif
            endif

            call update_physical_quantities

        end subroutine read_physical_quantities

        subroutine write_physical_quantities(ncid)
            integer, intent(in)     :: ncid
            integer                 :: grp_ncid
            character(*), parameter :: name = 'physical_quantities'

            ncerr = nf90_def_grp(ncid, name, grp_ncid)

            call check_netcdf_error("Faild to create NetCDF group '" // name // "'.")

            call write_netcdf_attribute(grp_ncid, 'standard_gravity', gravity)
            call write_netcdf_attribute(grp_ncid, 'latent_heat_of_vaporization', L_v)
            call write_netcdf_attribute(grp_ncid, 'specific_heat', c_p)
            call write_netcdf_attribute(grp_ncid, 'temperature_at_sea_level', theta_0)
            call write_netcdf_attribute(grp_ncid, 'planetary_angular_velocity', ang_vel)
            call write_netcdf_attribute(grp_ncid, 'saturation_specific_humidity_at_ground_level', q_0)
            call write_netcdf_attribute(grp_ncid, 'planet_vorticity', l_planet_vorticity)
            call write_netcdf_attribute(grp_ncid, 'latitude_degrees', lat_degrees)
            call write_netcdf_attribute(grp_ncid, 'scale_height', height_c)

        end subroutine write_physical_quantities

        subroutine print_physical_quantities
            write(*, "(a)") 'List of physical quantities (in MKS units):'
            write(*, "(a)") repeat("-", 78)
            call print_physical_quantity('standard gravity', gravity, 'm/s^2')
            call print_physical_quantity('latent heat of vaporization', L_v, 'J/kg')
            call print_physical_quantity('specific heat', c_p, 'J/(kg*K)')
            call print_physical_quantity('temperature at sea level', theta_0, 'K')
            call print_physical_quantity('planetary angular velocity', ang_vel, 'rad/s')
            call print_physical_quantity('saturation specific humidity at ground level', q_0)
            call print_physical_quantity('planetary vorticity', l_planet_vorticity)
            call print_physical_quantity('vertical planetary vorticity', f_cor(3), '1/s')
            call print_physical_quantity('horizontal planetary vorticity', f_cor(2), '1/s')
            call print_physical_quantity('latitude degrees', lat_degrees, 'deg')
            call print_physical_quantity('scale height', height_c, 'm')
            call print_physical_quantity('inverse scale height', lambda_c, '1/m')
            write(*, *) ''
        end subroutine print_physical_quantities

        subroutine print_physical_quantity_double(name, val, unit)
            character(*),           intent(in) :: name
            double precision,       intent(in) :: val
            character(*), optional, intent(in) :: unit
            character(64)                      :: fix_length_name

            fix_length_name = name
            if (present(unit)) then
                fix_length_name = name // ', ' // unit
            endif
            write (*, "(a, 1p,e14.7)") fix_length_name, val
        end subroutine print_physical_quantity_double

        subroutine print_physical_quantity_integer(name, val, unit)
            character(*),           intent(in) :: name
            integer,                intent(in) :: val
            character(*), optional, intent(in) :: unit
            character(64)                      :: fix_length_name

            fix_length_name = name
            if (present(unit)) then
                fix_length_name = name // ', ' // unit
            endif
            write (*, "(a, I14)") fix_length_name, val
        end subroutine print_physical_quantity_integer

        subroutine print_physical_quantity_logical(name, val, unit)
            character(*),           intent(in) :: name
            logical,                intent(in) :: val
            character(*), optional, intent(in) :: unit

            if (val) then
                call print_physical_quantity_character(name, 'true', unit)
            else
                call print_physical_quantity_character(name, 'false', unit)
            endif
        end subroutine print_physical_quantity_logical

        subroutine print_physical_quantity_character(name, val, unit)
            character(*),           intent(in) :: name
            character(*),           intent(in) :: val
            character(*), optional, intent(in) :: unit
            character(64)                      :: fix_length_name

            fix_length_name = name
            if (present(unit)) then
                fix_length_name = name // ', ' // unit
            endif
            write (*, "(a, a14)") fix_length_name, val
        end subroutine print_physical_quantity_character

end module physics


! maths_module.f90
! Routines for maths, random numbers, order parameters
MODULE maths_module

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  USE, INTRINSIC :: iso_fortran_env, ONLY : error_unit, iostat_end, iostat_eor

  IMPLICIT NONE
  PRIVATE

  ! Public random number routines
  PUBLIC :: init_random_seed, random_integer, random_normal, random_normals, pick
  PUBLIC :: random_vector
  PUBLIC :: random_vector_1, random_vector_2, random_vector_3
  PUBLIC :: random_perpendicular_vector
  PUBLIC :: random_rotate_vector, random_translate_vector
  PUBLIC :: random_rotate_vector_1, random_rotate_vector_2, random_rotate_vector_3, random_rotate_vector_4
  PUBLIC :: random_quaternion, random_rotate_quaternion
  PUBLIC :: metropolis

  ! Public low-level mathematical routines and string operations
  PUBLIC :: rotate_vector, rotate_quaternion, cross_product, outer_product, q_to_a, lowercase, solve

  ! Public order parameter calculations
  PUBLIC :: orientational_order, translational_order, nematic_order

  ! Generic interface for the pick functions
  INTERFACE pick
     MODULE PROCEDURE pick_i ! for integer weights
     MODULE PROCEDURE pick_r ! for real weights
  END INTERFACE pick

  ! Generic interface for the outer_product functions
  INTERFACE outer_product
     MODULE PROCEDURE outer_product_2 ! for 2 vectors giving a rank-2 result
     MODULE PROCEDURE outer_product_3 ! for 3 vectors giving a rank-3 result
     MODULE PROCEDURE outer_product_4 ! for 4 vectors giving a rank-4 result
     MODULE PROCEDURE outer_product_5 ! for 5 vectors giving a rank-5 result
  END INTERFACE outer_product

  ! Generic interface for the random_normals functions
  INTERFACE random_normals
     MODULE PROCEDURE random_normals_1 ! for rank 1 vector of normals
     MODULE PROCEDURE random_normals_2 ! for rank 2 vector of normals
  END INTERFACE random_normals

  ! Interface to select one of the random_vector algorithms
  INTERFACE random_vector
     MODULE PROCEDURE random_vector_1 ! choose an alternative one instead if you prefer
  END INTERFACE random_vector

  ! Interface to select one of the random_rotate_vector algorithms
  INTERFACE random_rotate_vector
     MODULE PROCEDURE random_rotate_vector_1 ! choose an alternative one instead if you prefer
  END INTERFACE random_rotate_vector

  ! Private data
  REAL, PARAMETER :: pi = 4.0*ATAN(1.0), twopi = 2.0*pi
  REAL, PARAMETER :: tol = 1.e-6

CONTAINS

  ! Routines associated with random number generation

  SUBROUTINE init_random_seed
    IMPLICIT NONE

    ! Initializes random number generator differently each time

    ! Prior to gfortran v7, calling the intrinsic RANDOM_SEED() routine initializes the
    ! random number generator with the same random seed to a default state,
    ! which may result in the same sequence being generated every time.
    ! If you have gfortran v6, you may like to replace this routine init_random_seed
    ! with the contents of file gnu_v6_init_random_seed.f90

    ! In gfortran v7 the random number generator was changed.
    ! Now, calling RANDOM_SEED() initializes the random number generator with random data
    ! retrieved from the operating system. Various other compilers behave the same way.
    ! We assume that this applies here.

    ! YOU SHOULD INVESTIGATE THE BEHAVIOUR FOR YOUR OWN COMPILER AND MACHINE IMPLEMENTATION

    CALL RANDOM_SEED()
  END SUBROUTINE init_random_seed

  FUNCTION random_integer ( k1, k2 ) RESULT ( k )
    IMPLICIT NONE
    INTEGER             :: k      ! Returns a uniformly distributed random integer
    INTEGER, INTENT(in) :: k1, k2 ! in range [k1,k2] inclusive

    INTEGER :: k_min, k_max
    REAL    :: zeta

    CALL RANDOM_NUMBER ( zeta )
    k_min = MIN ( k1, k2 )
    k_max = MAX ( k1, k2 )
    k     = k_min + FLOOR ( (k_max-k_min+1)*zeta )

    ! Guard against small danger of roundoff
    IF ( k < k_min ) k = k_min
    IF ( k > k_max ) k = k_max

  END FUNCTION random_integer

  FUNCTION random_normal ( mean, std ) RESULT ( r )
    IMPLICIT NONE
    REAL             :: r    ! Returns a normally-distributed random number with
    REAL, INTENT(in) :: mean ! specified mean and
    REAL, INTENT(in) :: std  ! specified standard deviation

    ! Box-Muller transform produces numbers in pairs
    ! We alternate between generating them, saving one for next time,
    ! and using the saved one from last time

    REAL, DIMENSION(2)      :: zeta
    REAL,              SAVE :: s
    LOGICAL,           SAVE :: saved = .FALSE.

    IF ( saved ) THEN     ! Saved number is available
       r = s              ! Normal, with mean=0, std=1
       r = mean + std * r ! Normal, with desired mean, std
       saved = .FALSE.    ! Flag to generate fresh numbers next time

    ELSE                                              ! Saved number is not available
       CALL RANDOM_NUMBER (zeta)                      ! Two uniformly distributed random numbers
       r = SQRT(-2.0*LOG(zeta(1)))*COS(twopi*zeta(2)) ! Normal, with mean=0, std=1
       s = SQRT(-2.0*LOG(zeta(1)))*SIN(twopi*zeta(2)) ! Also normal, with mean=0, std=1
       r = mean + std * r                             ! Normal, with desired mean, std
       saved = .TRUE.                                 ! Flag to use saved number next time

    END IF

  END FUNCTION random_normal

  SUBROUTINE random_normals_1 ( mean, std, r ) ! Normal random numbers
    IMPLICIT NONE
    REAL,               INTENT(in)  :: mean ! Specified mean and
    REAL,               INTENT(in)  :: std  ! specified standard deviation, used to return
    REAL, DIMENSION(:), INTENT(out) :: r    ! vector of normal random numbers

    INTEGER :: i

    DO i = 1, SIZE(r)
       r(i) = random_normal ( mean, std )
    END DO

  END SUBROUTINE random_normals_1

  SUBROUTINE random_normals_2 ( mean, std, r ) ! Normal random numbers
    IMPLICIT NONE
    REAL,                 INTENT(in)  :: mean  ! Specified mean and
    REAL,                 INTENT(in)  :: std   ! specified standard deviation, used to return
    REAL, DIMENSION(:,:), INTENT(out) :: r     ! array of normal random numbers

    INTEGER :: i, j

    DO j = 1, SIZE(r,dim=2)
       DO i = 1, SIZE(r,dim=1)
          r(i,j) = random_normal ( mean, std )
       END DO
    END DO

  END SUBROUTINE random_normals_2

  FUNCTION pick_r ( w ) RESULT ( k ) ! Pick amongst options with real weights
    IMPLICIT NONE
    INTEGER                        :: k ! Returns one of the options with probability proportional to
    REAL, DIMENSION(:), INTENT(in) :: w ! the supplied weights

    REAL :: cumw, zeta

    CALL RANDOM_NUMBER ( zeta ) ! Random number between 0 and 1
    zeta = zeta*SUM(w)          ! Scale up to total weight
    k    = 1
    cumw = w(1)
    DO ! Loop over possible outcomes
       IF ( zeta <= cumw ) EXIT ! Random number less than cumulative weight up to k
       k = k + 1
       IF ( k > SIZE(w) ) THEN ! Should never happen
          WRITE ( unit=error_unit, fmt='(a,2i15)' ) 'k error ', k, SIZE(w)
          STOP 'Error in pick_r'
       END IF
       cumw = cumw+w(k)
    END DO ! End loop over possible outcomes

  END FUNCTION pick_r

  FUNCTION pick_i ( w ) RESULT ( k ) ! Pick amongst options with integer weights
    IMPLICIT NONE
    INTEGER                           :: k ! Returns one of the options with probability proportional to
    INTEGER, DIMENSION(:), INTENT(in) :: w ! the supplied weights

    INTEGER :: cumw
    REAL    :: zeta

    CALL RANDOM_NUMBER ( zeta ) ! Random number between 0 and 1
    zeta = zeta*REAL(SUM(w))    ! Scale up to total weight
    k    = 1
    cumw = w(1)
    DO ! Loop over possible outcomes
       IF ( zeta <= REAL(cumw) ) EXIT ! Random number less than cumulative weight up to k
       k = k + 1
       IF ( k > SIZE(w) ) THEN ! Should never happen
          WRITE ( unit=error_unit, fmt='(a,2i15)' ) 'k error ', k, SIZE(w)
          STOP 'Error in pick_i'
       END IF
       cumw = cumw+w(k)
    END DO ! End loop over possible outcomes

  END FUNCTION pick_i

  FUNCTION random_vector_1 () RESULT ( e ) ! 1st alternative algorithm
    IMPLICIT NONE
    REAL, DIMENSION(3) :: e ! Returns a uniformly sampled unit vector

    ! The vector is chosen uniformly within the cube surrounding the unit sphere
    ! Vectors lying outside the unit sphere are rejected
    ! Having found a vector within the unit sphere, it is normalized
    ! Essentially the same routine will work in 2d, or for quaternions in 4d

    REAL :: norm

    DO ! Loop until within unit sphere
       CALL RANDOM_NUMBER ( e ) ! 3 random numbers uniformly sampled in range (0,1)
       e    = 2.0 * e - 1.0     ! Now in range (-1,+1) i.e. within containing cube
       norm = SUM ( e**2 )      ! Square modulus
       IF ( norm < 1.0 ) EXIT   ! Within unit sphere
    END DO ! End loop until within unit sphere

    e = e / SQRT ( norm ) ! Normalize

  END FUNCTION random_vector_1

  FUNCTION random_vector_2 () RESULT ( e ) ! 2nd alternative algorithm
    IMPLICIT NONE
    REAL, DIMENSION(3) :: e ! Returns a uniformly sampled unit vector

    ! The polar angles are chosen from the correct distribution
    ! sampling phi and cos(theta) uniformly
    ! Then these are used to compute components of e

    REAL               :: c, s, phi
    REAL, DIMENSION(2) :: zeta

    CALL RANDOM_NUMBER ( zeta ) ! Two uniformly sampled random numbers in range (0,1)
    c   = 2.0 * zeta(1) - 1.0   ! Random cos(theta) uniformly sampled in range (-1,+1)

    IF ( c >= 1.0 ) THEN         ! Guard against very small chance of roundoff error
       s = 0.0                   ! Set sin(theta) to zero
    ELSE
       s   = SQRT ( 1.0 - c**2 ) ! Calculate sin(theta) from cos(theta), always positive
    END IF

    phi = zeta(2) * twopi               ! Random angle uniformly sampled in range (0,2*pi)
    e   = [ s*COS(phi), s*SIN(phi), c ] ! Random unit vector

  END FUNCTION random_vector_2

  FUNCTION random_vector_3 () RESULT ( e ) ! 3rd alternative algorithm
    IMPLICIT NONE
    REAL, DIMENSION(3) :: e ! Returns a uniformly sampled unit vector

    REAL, DIMENSION(2) :: zeta
    REAL               :: norm, f

    DO ! Loop until within unit disk
       CALL RANDOM_NUMBER ( zeta ) ! Two uniform random numbers between 0 and 1
       zeta = 2.0 * zeta - 1.0     ! Now each between -1 and 1
       norm = SUM ( zeta**2 )      ! Squared magnitude
       IF ( norm < 1.0 ) EXIT      ! Test whether inside unit disk
    END DO ! End loop until within unit disk

    f = 2.0 * SQRT ( 1.0 - norm )
    e = [ zeta(1) * f, zeta(2) * f, 1.0 - 2.0 * norm ] ! On surface of unit sphere

  END FUNCTION random_vector_3

  FUNCTION random_perpendicular_vector ( old ) RESULT ( e )
    IMPLICIT NONE
    REAL, DIMENSION(3)             :: e   ! Returns a uniformly sampled unit vector perpendicular to
    REAL, DIMENSION(3), INTENT(in) :: old ! the old vector

    ! Note that we do not require the reference vector to be of unit length
    ! However we do require its length to be greater than a small tolerance!

    REAL, DIMENSION(3) :: n
    REAL               :: proj, norm

    norm = SUM ( old**2 ) ! Old squared length
    IF ( norm < tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es15.3)' ) 'old normalization error', norm, tol
       STOP 'Error in random_perpendicular_vector'
    END IF
    n = old / SQRT(norm) ! Normalized old vector

    DO ! Loop until generated vector is not too small
       e    = random_vector ()     ! Randomly oriented unit vector
       proj = DOT_PRODUCT ( e, n ) ! Projection along old
       e    = e - proj * n         ! Make e perpendicular to old
       norm = SUM ( e**2 )         ! Squared length
       IF ( norm > tol ) EXIT      ! Accept, unless e is too small (which is unlikely)
    END DO ! End loop until generated vector is not too small

    e = e / SQRT ( norm ) ! Normalize

  END FUNCTION random_perpendicular_vector

  FUNCTION random_translate_vector ( dr_max, old ) RESULT ( r )
    IMPLICIT NONE
    REAL, DIMENSION(3)             :: r      ! Returns a vector translated by a random amount with
    REAL,               INTENT(in) :: dr_max ! maximum displacement relative to
    REAL, DIMENSION(3), INTENT(in) :: old    ! the old vector

    ! A randomly chosen vector is added to the old one

    REAL, DIMENSION(3) :: zeta ! Random numbers

    CALL RANDOM_NUMBER ( zeta )   ! Three uniform random numbers in range (0,1)
    zeta = 2.0*zeta - 1.0         ! Now in range (-1,+1)
    r(:) = old(:) + zeta * dr_max ! Move to new position

  END FUNCTION random_translate_vector

  FUNCTION random_rotate_vector_1 ( angle_max, old ) RESULT ( e ) ! 1st alternative algorithm
    IMPLICIT NONE
    REAL, DIMENSION(3)             :: e         ! Returns a unit vector rotated by a
    REAL,               INTENT(in) :: angle_max ! maximum angle (in radians) relative to
    REAL, DIMENSION(3), INTENT(in) :: old       ! the old vector

    ! A small randomly chosen vector is added to the old one, and the result renormalized
    ! Provided angle_max is << 1, it is approximately the maximum rotation angle (in radians)
    ! The magnitude of the rotation is not uniformly sampled, but this should not matter

    ! Note that the old vector should be normalized and we test for this

    REAL :: norm

    norm = SUM ( old**2 ) ! Old squared length
    IF ( ABS ( norm - 1.0 ) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es20.8)' ) 'old normalization error', norm, tol
       STOP 'Error in random_rotate_vector_1'
    END IF

    ! Choose new orientation by adding random small vector
    e    = old + angle_max * random_vector ()
    norm = SUM ( e**2 )
    e    = e / SQRT(norm) ! Normalize

  END FUNCTION random_rotate_vector_1

  FUNCTION random_rotate_vector_2 ( angle_max, old ) RESULT ( e ) ! 2nd alternative algorithm
    IMPLICIT NONE
    REAL, DIMENSION(3)             :: e         ! Returns a unit vector rotated by a
    REAL,               INTENT(in) :: angle_max ! maximum angle (in radians) relative to
    REAL, DIMENSION(3), INTENT(in) :: old       ! the old vector

    ! The magnitude of the rotation is uniformly sampled
    ! The rotation axis is chosen randomly, perpendicular to the old orientation

    ! Note that the old vector should be normalized and we test for this

    REAL, DIMENSION(3) :: perp
    REAL               :: norm, angle, zeta

    norm = SUM ( old**2 ) ! Old squared length
    IF ( ABS ( norm - 1.0 ) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es20.8)' ) 'old normalization error', norm, tol
       STOP 'Error in random_rotate_vector_2'
    END IF

    perp = random_perpendicular_vector ( old ) ! Choose unit vector perpendicular to old

    CALL RANDOM_NUMBER ( zeta )              ! Uniform random number between 0 and 1
    angle = ( 2.0 * zeta - 1.0 ) * angle_max ! Uniform random angle in desired range

    e    = old * COS ( angle ) + perp * SIN ( angle ) ! Rotation in the (old,perp) plane
    norm = SUM ( e**2 )
    e    = e / SQRT(norm) ! Normalize (should be redundant)

  END FUNCTION random_rotate_vector_2

  FUNCTION random_rotate_vector_3 ( angle_max, old ) RESULT ( e ) ! 3rd alternative algorithm
    IMPLICIT NONE
    REAL, DIMENSION(3)             :: e         ! Returns a unit vector rotated by a
    REAL,               INTENT(in) :: angle_max ! maximum angle (in radians) relative to
    REAL, DIMENSION(3), INTENT(in) :: old       ! the old vector

    ! The magnitude of the rotation is uniformly sampled
    ! The rotation axis is a Cartesian axis selected at random
    ! Ref: Barker and Watts, Chem Phys Lett 3, 144 (1969)

    ! Note that the old vector should be normalized and we test for this

    INTEGER            :: k
    REAL, DIMENSION(3) :: axis
    REAL               :: angle, norm, zeta

    norm = SUM ( old**2 ) ! Old squared length
    IF ( ABS ( norm - 1.0 ) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es20.8)' ) 'old normalization error', norm, tol
       STOP 'Error in random_rotate_vector_3'
    END IF

    axis    = 0.0
    k       = random_integer (1,3) ! Random axis choice x=1, y=2, z=3
    axis(k) = 1.0

    CALL RANDOM_NUMBER ( zeta )              ! Uniform random number between 0 and 1
    angle = ( 2.0 * zeta - 1.0 ) * angle_max ! Uniform random angle in desired range

    e = rotate_vector ( angle, axis, old ) ! General rotation function

  END FUNCTION random_rotate_vector_3

  FUNCTION random_rotate_vector_4 ( angle_max, old ) RESULT ( e ) ! 4th alternative algorithm
    IMPLICIT NONE
    REAL, DIMENSION(3)             :: e         ! Returns a unit vector rotated by a
    REAL, INTENT(in)               :: angle_max ! maximum angle (in radians) relative to
    REAL, DIMENSION(3), INTENT(in) :: old       ! the old vector

    ! Ref: Marsaglia, Ann Maths Stat 43, 645 (1972)
    ! Uses a rejection technique to create a trial orientation
    ! subject to the constraint that the cosine of the angle
    ! turned through is greater than cos(angle_max)
    ! Not very efficient if angle_max is small

    ! Note that the old vector should be normalized and we test for this

    REAL :: cos_min, norm

    norm = SUM ( old**2 ) ! Old squared length
    IF ( ABS ( norm - 1.0 ) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es20.8)' ) 'old normalization error', norm, tol
       STOP 'Error in random_rotate_vector_4'
    END IF

    cos_min = COS ( angle_max )

    DO ! Loop until close enough
       e = random_vector ( )                        ! Choose completely random unit vector
       IF ( DOT_PRODUCT ( e, old ) > cos_min ) EXIT ! Close enough
    END DO ! End loop until close enough

  END FUNCTION random_rotate_vector_4

  FUNCTION random_quaternion () RESULT ( e )
    IMPLICIT NONE
    REAL, DIMENSION(0:3) :: e ! Returns a uniformly sampled unit quaternion

    REAL, DIMENSION(2) :: zeta
    REAL               :: norm1, norm2, f

    DO ! Loop until within unit disk
       CALL RANDOM_NUMBER ( zeta ) ! Two uniform random numbers between 0 and 1
       zeta = 2.0 * zeta - 1.0     ! Now each between -1 and 1
       norm1 = SUM ( zeta**2 )     ! Squared magnitude
       IF ( norm1 < 1.0 ) EXIT     ! Test for within unit disk
    END DO ! End loop until within unit disk

    e(0) = zeta(1)
    e(1) = zeta(2)

    DO ! Loop until within unit disk
       CALL RANDOM_NUMBER ( zeta ) ! Two uniform random numbers between 0 and 1
       zeta = 2.0 * zeta - 1.0     ! Now each between -1 and 1
       norm2 = SUM ( zeta**2 )     ! Squared magnitude
       IF ( norm2 < 1.0 ) EXIT     ! Test for within unit disk
    END DO ! End loop until within unit disk

    f = SQRT ( ( 1.0 - norm1 ) / norm2 )
    e(2) = zeta(1)*f
    e(3) = zeta(2)*f

  END FUNCTION random_quaternion

  FUNCTION random_rotate_quaternion ( angle_max, old ) RESULT ( e )
    IMPLICIT NONE
    REAL, DIMENSION(0:3)             :: e         ! Returns a unit quaternion rotated by a
    REAL,                 INTENT(in) :: angle_max ! maximum angle (in radians) relative to
    REAL, DIMENSION(0:3), INTENT(in) :: old       ! the old quaternion

    ! Note that the reference quaternion should be normalized and we test for this

    REAL, DIMENSION(3) :: axis
    REAL               :: zeta, angle, norm

    norm = SUM ( old**2 ) ! Old squared length
    IF ( ABS ( norm - 1.0 ) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es20.8)' ) 'old normalization error', norm, tol
       STOP 'Error in random_rotate_quaternion'
    END IF

    axis = random_vector ( )               ! Choose random unit vector
    CALL RANDOM_NUMBER ( zeta )            ! Random number between 0 and 1
    angle = ( 2.0*zeta - 1.0 ) * angle_max ! Uniform random angle in desired range

    e = rotate_quaternion ( angle, axis, old ) ! General rotation function

  END FUNCTION random_rotate_quaternion

  FUNCTION metropolis ( delta ) RESULT ( accept ) ! Conduct Metropolis test, with safeguards
    IMPLICIT NONE
    LOGICAL          :: accept ! Returns decision
    REAL, INTENT(in) :: delta  ! Negative of argument of exponential

    REAL            :: zeta
    REAL, PARAMETER :: exponent_guard = 75.0

    IF ( delta > exponent_guard ) THEN ! Too high, reject without evaluating
       accept = .FALSE.
    ELSE IF ( delta < 0.0 ) THEN ! Downhill, accept without evaluating
       accept = .TRUE.
    ELSE
       CALL RANDOM_NUMBER ( zeta ) ! Uniform random number in range (0,1)
       accept = EXP(-delta) > zeta ! Metropolis test
    END IF

  END FUNCTION metropolis

  ! Low level mathematical operations and string manipulation

  FUNCTION rotate_vector ( angle, axis, old ) RESULT ( e )
    IMPLICIT NONE
    REAL, DIMENSION(3)             :: e     ! Returns a vector rotated by
    REAL,               INTENT(in) :: angle ! specified rotation angle (in radians) about
    REAL, DIMENSION(3), INTENT(in) :: axis  ! specified rotation axis relative to
    REAL, DIMENSION(3), INTENT(in) :: old   ! old vector

    ! Note that the axis vector should be normalized and we test for this
    ! In general, the old vector need not be normalized, and the same goes for the result
    ! although quite often in our applications they will be

    REAL :: proj, c, s, norm

    norm = SUM ( axis**2 ) ! Axis squared length
    IF ( ABS ( norm - 1.0 ) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es20.8)' ) 'axis normalization error', norm, tol
       STOP 'Error in rotate_vector'
    END IF

    c    = COS ( angle )
    s    = SIN ( angle )
    proj = DOT_PRODUCT ( axis, old ) ! The two vectors need not be perpendicular

    ! Standard (Goldstein) rotation formula
    e = c * old + ( 1.0 - c ) * proj * axis + s * cross_product ( axis, old )

  END FUNCTION rotate_vector

  FUNCTION rotate_quaternion ( angle, axis, old ) RESULT ( e )
    IMPLICIT NONE
    REAL, DIMENSION(0:3)             :: e     ! Returns a quaternion rotated by
    REAL,                 INTENT(in) :: angle ! specified rotation angle (in radians) about
    REAL, DIMENSION(3),   INTENT(in) :: axis  ! specified rotation axis relative to
    REAL, DIMENSION(0:3), INTENT(in) :: old   ! old quaternion

    ! Note that the axis vector should be normalized and we test for this
    ! In general, the old quaternion need not be normalized, and the same goes for the result
    ! although in our applications we only ever use unit quaternions (to represent orientations)

    REAL                 :: norm
    REAL, DIMENSION(0:3) :: rot

    norm = SUM ( axis**2 ) ! Axis squared length
    IF ( ABS ( norm - 1.0 ) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es20.8)' ) 'axis normalization error', norm, tol
       STOP 'Error in rotate_quaternion'
    END IF

    ! Standard formula for rotation quaternion, using half angles
    rot(0)   = COS(0.5*angle)
    rot(1:3) = SIN(0.5*angle)*axis

    e = quatmul ( rot, old ) ! Apply rotation to old quaternion

  END FUNCTION rotate_quaternion

  FUNCTION quatmul ( a, b ) RESULT ( c )
    IMPLICIT NONE
    REAL, DIMENSION(0:3)             :: c    ! Returns quaternion product of
    REAL, DIMENSION(0:3), INTENT(in) :: a, b ! two supplied quaternions

    c(0) = a(0)*b(0) - a(1)*b(1) - a(2)*b(2) - a(3)*b(3)
    c(1) = a(1)*b(0) + a(0)*b(1) - a(3)*b(2) + a(2)*b(3)
    c(2) = a(2)*b(0) + a(3)*b(1) + a(0)*b(2) - a(1)*b(3)
    c(3) = a(3)*b(0) - a(2)*b(1) + a(1)*b(2) + a(0)*b(3)

  END FUNCTION quatmul

  FUNCTION cross_product ( a, b ) RESULT ( c )
    IMPLICIT NONE
    REAL, DIMENSION(3)             :: c    ! Returns vector cross product of
    REAL, DIMENSION(3), INTENT(in) :: a, b ! two supplied vectors
    c(1) = a(2)*b(3) - a(3)*b(2)
    c(2) = a(3)*b(1) - a(1)*b(3)
    c(3) = a(1)*b(2) - a(2)*b(1)
  END FUNCTION cross_product

  FUNCTION outer_product_2 ( a, b ) RESULT ( c )
    IMPLICIT NONE
    REAL, DIMENSION(:),              INTENT(IN) :: a, b ! Given two supplied vectors,
    REAL, DIMENSION(SIZE(a),SIZE(b))            :: c    ! returns their rank-2 outer product

    INTEGER :: i, j

    DO j = 1, SIZE(b)
       DO i = 1, SIZE(a)
          c(i,j) = a(i) * b(j)
       END DO
    END DO

    ! The following one-line statement is equivalent, but the above loops are clearer
    ! c = SPREAD(a,dim=2,ncopies=SIZE(b)) * SPREAD(b,dim=1,ncopies=SIZE(a))

  END FUNCTION outer_product_2

  FUNCTION outer_product_3 ( a, b, c ) RESULT (d)
    IMPLICIT NONE
    REAL, DIMENSION(:),                      INTENT(IN) :: a, b, c ! Given three supplied vectors,
    REAL, DIMENSION(SIZE(a),SIZE(b),SIZE(c))            :: d       ! returns their rank-3 outer product

    INTEGER :: i, j, k

    DO k = 1, SIZE(c)
       DO j = 1, SIZE(b)
          DO i = 1, SIZE(a)
             d(i,j,k) = a(i) * b(j) * c(k)
          END DO
       END DO
    END DO

  END FUNCTION outer_product_3

  FUNCTION outer_product_4 ( a, b, c, d ) RESULT (e)
    IMPLICIT NONE
    REAL, DIMENSION(:),                   INTENT(IN) :: a, b, c, d ! Given four supplied vectors,
    REAL, DIMENSION(SIZE(a),SIZE(b),SIZE(c),SIZE(d)) :: e          ! returns their rank-4 outer product

    INTEGER :: i, j, k, l

    DO l = 1, SIZE(d)
       DO k = 1, SIZE(c)
          DO j = 1, SIZE(b)
             DO i = 1, SIZE(a)
                e(i,j,k,l) = a(i) * b(j) * c(k) * d(l)
             END DO
          END DO
       END DO
    END DO

  END FUNCTION outer_product_4

  FUNCTION outer_product_5 ( a, b, c, d, e ) RESULT (f)
    IMPLICIT NONE
    REAL, DIMENSION(:),                           INTENT(IN) :: a, b, c, d, e ! Given five  supplied vectors,
    REAL, DIMENSION(SIZE(a),SIZE(b),SIZE(c),SIZE(d),SIZE(e)) :: f             ! returns their rank-5 outer product

    INTEGER :: i, j, k, l, m

    DO m = 1, SIZE(e)
       DO l = 1, SIZE(d)
          DO k = 1, SIZE(c)
             DO j = 1, SIZE(b)
                DO i = 1, SIZE(a)
                   f(i,j,k,l,m) = a(i) * b(j) * c(k) * d(l) * e(m)
                END DO
             END DO
          END DO
       END DO
    END DO

  END FUNCTION outer_product_5

  FUNCTION lowercase ( oldstring ) RESULT ( newstring )
    IMPLICIT NONE
    CHARACTER(len=*),             INTENT(in) :: oldstring ! Given a supplied string,
    CHARACTER(len=LEN(oldstring))            :: newstring ! returns a copy converted to lowercase

    INTEGER :: i, k

    ! Leaves non-alphabetic characters unchanged

    DO i = 1, LEN(oldstring)
       k = IACHAR(oldstring(i:i))
       IF ( k >= IACHAR('A') .AND. k <= IACHAR('Z') ) THEN
          k = k + IACHAR('a') - IACHAR('A')
          newstring(i:i) = ACHAR(k)
       ELSE
          newstring(i:i) = oldstring(i:i)
       END IF
    END DO
  END FUNCTION lowercase

  ! Order parameter routines

  FUNCTION translational_order ( r, k ) RESULT ( order )
    IMPLICIT NONE
    REAL                                          :: order ! Returns a translational order parameter from
    REAL,    DIMENSION(:,:), INTENT(in)           :: r     ! set of molecular position vectors (3,n), and
    INTEGER, DIMENSION(3),   INTENT(in), OPTIONAL :: k     ! lattice reciprocal vector (integer)

    ! Calculate the "melting factor" for translational order
    ! based on a single k-vector characterizing the original lattice
    ! and commensurate with the periodic box
    ! It is assumed that both r and k are in box=1 units
    ! k = (l,m,n) where l,m,n are integers, must be multiplied by 2*pi to get real k
    ! If optional argument k is omitted, we default to a choice
    ! based on the FCC lattice, if this makes sense based on the number of atoms
    ! order = 1 when all atoms are on their lattice positions
    ! order = 1/sqrt(n), approximately, for disordered positions

    INTEGER            :: i, n, nc
    REAL, DIMENSION(3) :: k_real
    REAL               :: kr
    COMPLEX            :: rho ! Fourier component of single-particle density

    IF ( SIZE(r,dim=1) /= 3 ) THEN
       WRITE ( unit=error_unit, fmt='(a,i15)' ) 'Error in r dimension ', SIZE(r,dim=1)
       STOP 'Error in translational_order'
    END IF
    n = SIZE(r,dim=2)

    IF ( PRESENT ( k ) ) THEN
       k_real = twopi * REAL ( k )
    ELSE                                          ! Make arbitrary choice assuming FCC
       nc = NINT ( ( REAL(n)/4.0 ) ** (1.0/3.0) ) ! number of FCC unit cells
       IF ( 4*nc**3 /= n ) THEN ! Check that n does indeed correspond to FCC lattice
          WRITE ( unit=error_unit, fmt='(a,2i15)' ) 'Error in value of n ', 4*nc**3, n
          STOP 'Error in translational_order'
       END IF
       k_real = twopi * REAL( [-nc,nc,-nc] )      ! arbitrary fcc reciprocal vector
    END IF

    rho = ( 0.0, 0.0 )

    DO i = 1, n
       kr  = DOT_PRODUCT ( k_real, r(:,i) )
       rho = rho + CMPLX ( COS(kr), SIN(kr) )
    END DO

    rho   = rho / REAL(n)
    order = REAL ( CONJG(rho)*rho )

  END FUNCTION translational_order

  FUNCTION orientational_order ( e ) RESULT ( order )
    IMPLICIT NONE
    REAL                             :: order ! Returns a crystal orientational order parameter from
    REAL, DIMENSION(:,:), INTENT(in) :: e     ! a set of molecular orientation vectors (3,n)

    ! Calculates an orientational order parameter to monitor "melting"
    ! The parameter depends completely on knowing the orientations of the molecules
    ! in the original crystal lattice, and here we assume a specific alpha-fcc crystal
    ! of the same kind as was set up in initialize.f90 and initialize_module.f90
    ! Four molecules per unit cell, each pointing along a body-diagonal
    ! Order parameter can be a low-ranking (e.g. 1st or 2nd) Legendre polynomial

    ! Note that this is not the same as the order parameter characterizing a nematic liquid crystal

    INTEGER :: n, nc, i, i0
    REAL    :: c

    REAL, DIMENSION(3,4), PARAMETER :: e0 = RESHAPE (  SQRT(1.0/3.0)*[ &
         &  1.0,  1.0,  1.0,    1.0, -1.0, -1.0,  &
         & -1.0,  1.0, -1.0,   -1.0, -1.0,  1.0 ],[3,4] ) ! Orientations in unit cell

    IF ( SIZE(e,dim=1) /= 3 ) THEN
       WRITE ( unit=error_unit, fmt='(a,i15)' ) 'Error in e dimension ', SIZE(e,dim=1)
       STOP 'Error in orientational_order'
    END IF
    n  = SIZE(e,dim=2)
    nc = NINT ( ( REAL(n)/4.0 ) ** (1.0/3.0) )
    IF ( 4*nc**3 /= n ) THEN
       WRITE ( unit=error_unit, fmt='(a,2i15)' ) 'Error in value of n ', 4*nc**3, n
       STOP 'Error in orientational_order'
    END IF

    order = 0.0

    DO i = 1, n
       i0    = MODULO ( i, 4 ) + 1              ! Select appropriate original orientation
       c     = DOT_PRODUCT ( e(:,i), e0(:,i0) ) ! Cosine of angle
       order = order + 1.5*c**2 - 0.5           ! Second Legendre polynomial
    END DO

    order = order / REAL ( n )

  END FUNCTION orientational_order

  FUNCTION nematic_order ( e ) RESULT ( order )
    IMPLICIT NONE
    REAL                             :: order ! Returns a nematic orientational order parameter from
    REAL, DIMENSION(:,:), INTENT(in) :: e     ! a set of molecular orientation vectors (3,n)

    ! Calculate the nematic order parameter <P2(cos(theta))>
    ! where theta is the angle between a molecular axis and the director
    ! which is the direction that maximises the order parameter
    ! This is obtained by finding the largest eigenvalue of
    ! the 3x3 second-rank traceless order tensor

    ! Note that this is not the same as the order parameter characterizing a crystal

    INTEGER              :: i, n
    REAL, DIMENSION(3,3) :: q         ! order tensor
    REAL                 :: h, g, psi ! used in eigenvalue calculation

    IF ( SIZE(e,dim=1) /= 3 ) THEN
       WRITE ( unit=error_unit, fmt='(a,i15)' ) 'Error in e dimension ', SIZE(e,dim=1)
       STOP 'Error in nematic_order'
    END IF
    n = SIZE(e,dim=2)

    ! Order tensor: outer product of each orientation vector, summed over n molecules
    q = SUM ( SPREAD ( e, dim=2, ncopies=3) * SPREAD ( e, dim=1, ncopies=3 ), dim = 3 )
    q = 1.5 * q / REAL(n)                ! Normalize
    FORALL (i=1:3) q(i,i) = q(i,i) - 0.5 ! Make traceless

    ! Trigonometric solution of characteristic cubic equation, assuming real roots

    h =      q(1,1) * q(2,2) - q(1,2) * q(2,1) &
         & + q(2,2) * q(3,3) - q(2,3) * q(3,2) &
         & + q(3,3) * q(1,1) - q(3,1) * q(1,3)
    h = h / 3.0

    g =      q(1,1) * q(2,2) * q(3,3) - q(1,1) * q(2,3) * q(3,2) &
         & + q(1,2) * q(2,3) * q(3,1) - q(2,2) * q(3,1) * q(1,3) &
         & + q(2,1) * q(3,2) * q(1,3) - q(3,3) * q(1,2) * q(2,1)

    h = SQRT(-h)
    psi = -0.5 * g / h**3
    IF ( psi < -1.0 ) psi = -1.0
    IF ( psi >  1.0 ) psi =  1.0
    psi = ACOS(psi)
    h = -2.0*h

    ! Select largest root
    order = MAXVAL ( [ h*COS(psi/3.0), h*COS((psi+2.0*pi)/3.0), h*COS((psi+4.0*pi)/3.0) ] )

  END FUNCTION nematic_order

  FUNCTION solve ( a, b ) RESULT ( x )
    IMPLICIT NONE
    REAL, DIMENSION(3)               :: x ! Returns a vector x, the solution of ax=b, for
    REAL, DIMENSION(3,3), INTENT(in) :: a ! supplied 3x3 matrix, and
    REAL, DIMENSION(3),   INTENT(in) :: b ! supplied constant vector

    ! Use Cramer's rule to solve 3x3 linear system

    REAL                 :: d
    REAL, DIMENSION(3,3) :: ai
    INTEGER              :: i

    d = determinant ( a )
    IF ( ABS(d) < tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,i15)' ) 'Error, determinant zero ', d
       STOP 'Error in solve'
    END IF

    DO i = 1, 3
       ai      = a
       ai(:,i) = b ! Replace i-th column of a
       x(i)    = determinant ( ai ) / d
    END DO
  END FUNCTION solve

  FUNCTION determinant ( a ) RESULT ( d )
    IMPLICIT NONE
    REAL                 :: d ! Returns determinant of
    REAL, DIMENSION(3,3) :: a ! supplied 3x3 matrix

    d =      a(1,1) * a(2,2) * a(3,3) - a(1,1) * a(2,3) * a(3,2) &
         & + a(1,2) * a(2,3) * a(3,1) - a(2,2) * a(3,1) * a(1,3) &
         & + a(2,1) * a(3,2) * a(1,3) - a(3,3) * a(1,2) * a(2,1)

  END FUNCTION determinant

  FUNCTION q_to_a ( q ) RESULT ( a )
    IMPLICIT NONE
    REAL, DIMENSION(3,3)             :: a ! Returns a 3x3 rotation matrix calculated from
    REAL, DIMENSION(0:3), INTENT(in) :: q ! supplied quaternion

    ! The rows of the rotation matrix correspond to unit vectors of the molecule in the space-fixed frame
    ! The third row  a(3,:) is "the" axis of the molecule, for uniaxial molecules
    ! Use a to convert space-fixed to body-fixed axes thus: db = matmul(a,ds)
    ! Use transpose of a to convert body-fixed to space-fixed axes thus: ds = matmul(db,a)

    ! The supplied quaternion should be normalized and we check for this

    REAL :: norm

    norm = SUM ( q**2 ) ! Quaternion squared length
    IF ( ABS ( norm - 1.0 ) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a,2es20.8)' ) 'quaternion normalization error', norm, tol
       STOP 'Error in q_to_a'
    END IF

    ! Write out row by row, for clarity

    a(1,:) = [ q(0)**2+q(1)**2-q(2)**2-q(3)**2,   2*(q(1)*q(2)+q(0)*q(3)),       2*(q(1)*q(3)-q(0)*q(2))     ] ! 1st row
    a(2,:) = [     2*(q(1)*q(2)-q(0)*q(3)),   q(0)**2-q(1)**2+q(2)**2-q(3)**2,   2*(q(2)*q(3)+q(0)*q(1))     ] ! 2nd row
    a(3,:) = [     2*(q(1)*q(3)+q(0)*q(2)),       2*(q(2)*q(3)-q(0)*q(1)),   q(0)**2-q(1)**2-q(2)**2+q(3)**2 ] ! 3rd row
  END FUNCTION q_to_a

END MODULE maths_module


!*==clartv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CLARTV applies a vector of plane rotations with real cosines and complex sines to the elements of a pair of vectors.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLARTV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC )
!
!       .. Scalar Arguments ..
!       INTEGER            INCC, INCX, INCY, N
!       ..
!       .. Array Arguments ..
!       REAL               C( * )
!       COMPLEX            S( * ), X( * ), Y( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CLARTV applies a vector of complex plane rotations with real cosines
!> to elements of the complex vectors x and y. For i = 1,2,...,n
!>
!>    ( x(i) ) := (        c(i)   s(i) ) ( x(i) )
!>    ( y(i) )    ( -conjg(s(i))  c(i) ) ( y(i) )
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of plane rotations to be applied.
!> \endverbatim
!>
!> \param[in,out] X
!> \verbatim
!>          X is COMPLEX array, dimension (1+(N-1)*INCX)
!>          The vector x.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>          The increment between elements of X. INCX > 0.
!> \endverbatim
!>
!> \param[in,out] Y
!> \verbatim
!>          Y is COMPLEX array, dimension (1+(N-1)*INCY)
!>          The vector y.
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>          The increment between elements of Y. INCY > 0.
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is REAL array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!> \endverbatim
!>
!> \param[in] S
!> \verbatim
!>          S is COMPLEX array, dimension (1+(N-1)*INCC)
!>          The sines of the plane rotations.
!> \endverbatim
!>
!> \param[in] INCC
!> \verbatim
!>          INCC is INTEGER
!>          The increment between elements of C and S. INCC > 0.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE CLARTV(N,X,Incx,Y,Incy,C,S,Incc)
      IMPLICIT NONE
!*--CLARTV111
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Incc , Incx , Incy , N
!     ..
!     .. Array Arguments ..
      REAL C(*)
      COMPLEX S(*) , X(*) , Y(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , ic , ix , iy
      COMPLEX xi , yi
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC CONJG
!     ..
!     .. Executable Statements ..
!
      ix = 1
      iy = 1
      ic = 1
      DO i = 1 , N
         xi = X(ix)
         yi = Y(iy)
         X(ix) = C(ic)*xi + S(ic)*yi
         Y(iy) = C(ic)*yi - CONJG(S(ic))*xi
         ix = ix + Incx
         iy = iy + Incy
         ic = ic + Incc
      ENDDO
!
!     End of CLARTV
!
      END SUBROUTINE CLARTV