!--------------------------------------------------------------------------------------------------!
! Module eq
!
! Routines for manipulating earthquake source parameters, including moment tensors, principal
! axes, fault geometries, slip kinematics, magnitudes, and more.
!
! The algorithms for most of these subroutines come from two sources:
!     Aki, K., Richards, P.G. (2002). Quantitative Seismology, Sausalito, CA: University Science
!         Books.
!     Jost, M.L., Herrmann, R.B. (1989). A student's guide to and review of moment tensors.
!         Seismological Research Letters 60, 37-57.
!
!--------------------------------------------------------------------------------------------------!
module eq

double precision, parameter :: dynecm2nm = 1.0d-7
double precision, parameter :: nm2dynecm = 1.0d7

public :: dynecm2nm
public :: nm2dynecm

public :: mag2mom
public :: mom2mag

public :: mij2dcp
public :: mij2mag
public :: mij2mom
public :: mij2pnt
public :: mij2sdr
public :: mij2sv
public :: mij2ter

public :: pnt2dcp
public :: pnt2mag
public :: pnt2mij
public :: pnt2mom
public :: pnt2mom_nondc
public :: pnt2sdr
public :: pnt2sv
public :: pnt2ter

public :: sdr2mij
public :: sdr2pnt
public :: sdr2sdr
public :: sdr2sv
public :: sdr2ter

public :: sdr2kagan
public :: mij2kagan
public :: kaganangle

public :: empirical

!--------------------------------------------------------------------------------------------------!
contains
!--------------------------------------------------------------------------------------------------!

!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!---------------------------------- mij2xxx -------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!

subroutine mij2dcp(mrr,mpp,mtt,mrp,mrt,mtp,dcp)
!----
! Compute the percent double couple of a moment tensor.
!----

implicit none

! Arguments
double precision :: mrr, mpp, mtt, mrp, mrt, mtp, dcp

! Local variables
double precision :: pnt(12)

! Compute eigenvectors and eigenvalues
call mij2pnt(mrr,mpp,mtt,mrp,mrt,mtp,pnt)

! Compute double couple percentage
call pnt2dcp(pnt,dcp)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine mij2mag(mrr,mpp,mtt,mrp,mrt,mtp,mag,mode)
!----
! Calculate the moment magnitude of the moment tensor
!----

use io, only: stderr
implicit none

! Arguments
double precision :: mrr, mpp, mtt, mrp, mrt, mtp, mag
character(len=*) :: mode

! Local variables
double precision :: pnt(12), mom

call mij2pnt(mrr,mpp,mtt,mrp,mrt,mtp,pnt)
if (mode.eq.'dc') then
    call pnt2mom(pnt,mom)
elseif (mode.eq.'nondc') then
    call pnt2mom_nondc(pnt,mom)
else
    write(stderr,*) 'mij2mag: no mode named "',trim(mode),'"'
    write(stderr,*) 'returning with magnitude of -100'
    mag = -100.0d0
    return
endif
call mom2mag(mom,mag)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine mij2mom(mrr,mpp,mtt,mrp,mrt,mtp,mom,mode)
!----
! Calculate the scalar moment of the moment tensor
!----

use io, only: stderr
implicit none

! Arguments
double precision :: mrr, mpp, mtt, mrp, mrt, mtp, mom
character(len=*) :: mode

! Local variables
double precision :: pnt(12)

call mij2pnt(mrr,mpp,mtt,mrp,mrt,mtp,pnt)
if (mode.eq.'dc') then
    call pnt2mom(pnt,mom)
elseif (mode.eq.'nondc') then
    call pnt2mom_nondc(pnt,mom)
else
    write(stderr,*) 'mij2mag: no mode named "',trim(mode),'"'
    write(stderr,*) 'returning with moment of 0'
    mom = 0.0d0
    return
endif

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine mij2pnt(mrr,mtt,mpp,mrt,mrp,mtp,pnt)
!----
! Compute the P, N, and T axis orientations (eigenvectors) in east-north-vertical coordinates and
! magnitudes (eigenvalues) for a moment tensor given in spherical coordinates.
!----

use io, only: stderr

#ifdef USE_LAPACK
! With LAPACK, we only need the cross_product and dot_product routines from the algebra module
use algebra, only: cross_product, dot_product
#else
! Without LAPACK, we also need the eigen routines from the algebra module
use algebra, only: cross_product, dot_product, jacobi, eig_sort
#endif

implicit none

! Arguments
double precision :: mrr, mtt, mpp, mrt, mrp, mtp, pnt(12)

! Local variables
double precision :: m_enz(3,3), eigvals(3), xp(3), dp

#ifdef USE_LAPACK

! Variables for running LAPACK dysev (double precision symmetric matrix eigen analysis)
integer :: info, lwork
double precision, allocatable :: work(:)

#else

! Variables for running Numerical Recipes jacobi (symmetric matrix eigen analysis) and eig_sort
integer :: nrot, ierr
double precision :: eigvecs(3,3)

#endif

! Initialize PNT
pnt = 0.0d0

! Convert moment tensor from spherical coordinates to local east-north-vertical coordinates, where
! r=up, t=south, and p=east
m_enz(3,3) =  mrr     ! mrr =  mzz
m_enz(2,2) =  mtt     ! mtt =  mnn
m_enz(1,1) =  mpp     ! mpp =  mee
m_enz(2,3) = -mrt     ! mrt = -mnz
m_enz(3,2) = -mrt
m_enz(1,3) =  mrp     ! mrp =  mez
m_enz(3,1) =  mrp
m_enz(1,2) = -mtp     ! mtp = -men
m_enz(2,1) = -mtp

! Use LAPACK eigensystem solver if it is available. Otherwise, use Numerical Recipes routine.

#ifdef USE_LAPACK

! Query the optimal workspace
allocate(work(1))
lwork = -1
call dsyev('Vectors','Upper',3,m_enz,3,eigvals,work,lwork,info)
lwork = int(work(1))
deallocate(work)
allocate(work(lwork))

! Solve eigenproblem
call dsyev('Vectors','Upper',3,m_enz,3,eigvals,work,lwork,info)

if (info.ne.0) then
    write(stderr,*) 'mij2pnt: error in dsyev; returning pnt with zeros'
    return
endif

! Eigenvectors overwrite the input array
pnt(1) = m_enz(1,1)
pnt(2) = m_enz(2,1)
pnt(3) = m_enz(3,1)
pnt(4) = m_enz(1,2)
pnt(5) = m_enz(2,2)
pnt(6) = m_enz(3,2)
pnt(7) = m_enz(1,3)
pnt(8) = m_enz(2,3)
pnt(9) = m_enz(3,3)

! Eigenvalues are in the w array
pnt(10) = eigvals(1)
pnt(11) = eigvals(2)
pnt(12) = eigvals(3)

#else

! Calculate eigenvalues and eigenvectors with Numerical Recipes routine
call jacobi(m_enz,3,3,eigvals,eigvecs,nrot,ierr)
if (ierr.ne.0) then
    write(stderr,*) 'mij2pnt: error in jacobi; returning pnt with zeros'
    return
endif

call eig_sort(eigvals,eigvecs,3,3)

! Eigenvectors are in the mat array
pnt(1) = eigvecs(1,1)
pnt(2) = eigvecs(2,1)
pnt(3) = eigvecs(3,1)
pnt(4) = eigvecs(1,2)
pnt(5) = eigvecs(2,2)
pnt(6) = eigvecs(3,2)
pnt(7) = eigvecs(1,3)
pnt(8) = eigvecs(2,3)
pnt(9) = eigvecs(3,3)

! Eigenvalues are in the vec array
pnt(10) = eigvals(1)
pnt(11) = eigvals(2)
pnt(12) = eigvals(3)

#endif

! Verify that eigenvectors are right handed
call cross_product(pnt(1:3),pnt(4:6),xp)
call dot_product(xp,pnt(7:9),dp)
if (dp.lt.0.0d0) then
    pnt(7) = -pnt(7)
    pnt(8) = -pnt(8)
    pnt(9) = -pnt(9)
endif

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine mij2sdr(mrr,mtt,mpp,mrt,mrp,mtp,str1,dip1,rak1,str2,dip2,rak2)
!----
! Compute the strike, dip, and rake angles of both nodal planes of the best-fitting double couple
! source for a moment tensor source provided in spherical coordinates used by the Global Centroid
! Moment Tensor project.
!----

implicit none

! Arguments
double precision :: mrr, mtt, mpp, mrt, mrp, mtp, str1, dip1, rak1, str2, dip2, rak2

! Local variables
double precision :: pnt(12)

! Compute the P, N, and T axes for this moment tensor
call mij2pnt(mrr,mtt,mpp,mrt,mrp,mtp,pnt)

! Compute the strike, dip, and rake of one nodal plane
call pnt2sdr(pnt,str1,dip1,rak1,str2,dip2,rak2)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine mij2sv(mrr,mtt,mpp,mrt,mrp,mtp,slip_vec1,slip_vec2)
!----
! Compute the slip vectors of the two nodal planes for the best-fitting double couple source
! of a moment tensor.
!----

implicit none

! Arguments
double precision :: mrr, mtt, mpp, mrt, mrp, mtp, slip_vec1(3), slip_vec2(3)

! Local variables
double precision :: str1, dip1, rak1, str2, dip2, rak2

! Calculate best fitting double couple
call mij2sdr(mrr,mtt,mpp,mrt,mrp,mtp,str1,dip1,rak1,str2,dip2,rak2)

! Compute slip vector for both nodal planes
call sdr2sv(str1,dip1,rak1,slip_vec1)
call sdr2sv(str2,dip2,rak2,slip_vec2)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine mij2ter(mrr,mtt,mpp,mrt,mrp,mtp,fth,fss,fno)
!----
! Compute the fraction thrust, strike-slip, and normal for a moment tensor.
!----

implicit none

double precision :: mrr, mtt, mpp, mrt, mrp, mtp, fth, fss, fno
double precision :: pnt(12)

! Find eigenvectors and eigenvalues
call mij2pnt(mrr,mtt,mpp,mrt,mrp,mtp,pnt)

! Compute fraction thrust, strike-slip, and normal
call pnt2ter(pnt,fth,fss,fno)

return
end subroutine

!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!---------------------------------- pnt2xxx -------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!

subroutine pnt2dcp(pnt,dcp)
!----
! Compute the percent double couple from the P, N, and T values.
!----

implicit none

! Arguments
double precision :: pnt(12), dcp

if (abs(pnt(10)).gt.abs(pnt(12))) then
    dcp = 1.0d0 - 2.0d0*abs(pnt(11)/pnt(10))
else
    dcp = 1.0d0 - 2.0d0*abs(pnt(11)/pnt(12))
endif

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine pnt2mij(pnt,mrr,mtt,mpp,mrt,mrp,mtp)
!----
! Transform the eigenvectors and eigenvalues of the moment tensor (in east-north-vertical
! coordinates) to the full moment tensor (in Global Centroid Moment Tensor project spherical
! coordinates).
!----

implicit none

! Arguments
double precision :: pnt(12), mrr, mtt, mpp, mrt, mrp, mtp

! Local variables
double precision :: mxx, myy, mzz, mxy, mxz, myz

! Calculate the moment tensor in x=east, y=north, z=vertical coordinates
mxx = pnt(10)*pnt(1)*pnt(1) + pnt(11)*pnt(4)*pnt(4) + pnt(12)*pnt(7)*pnt(7)
myy = pnt(10)*pnt(2)*pnt(2) + pnt(11)*pnt(5)*pnt(5) + pnt(12)*pnt(8)*pnt(8)
mzz = pnt(10)*pnt(3)*pnt(3) + pnt(11)*pnt(6)*pnt(6) + pnt(12)*pnt(9)*pnt(9)
mxy = pnt(10)*pnt(1)*pnt(2) + pnt(11)*pnt(4)*pnt(5) + pnt(12)*pnt(7)*pnt(8)
mxz = pnt(10)*pnt(1)*pnt(3) + pnt(11)*pnt(4)*pnt(6) + pnt(12)*pnt(7)*pnt(9)
myz = pnt(10)*pnt(2)*pnt(3) + pnt(11)*pnt(5)*pnt(6) + pnt(12)*pnt(8)*pnt(9)

! Convert to spherical coordinates
mrr = mzz
mtt = myy
mpp = mxx
mrt = -myz
mrp = mxz
mtp = -mxy

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine pnt2mag(pnt,mag)
!----
! Calculate the moment magnitude from the P and T magnitudes
!----

implicit none

! Arguments
double precision :: pnt(12), mag

! Local variables
double precision :: mom

call pnt2mom(pnt,mom)
call mom2mag(mom,mag)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine pnt2mag_nondc(pnt,mag)
!----
! Calculate the moment magnitude from the P and T magnitudes
!----

implicit none

! Arguments
double precision :: pnt(12), mag

! Local variables
double precision :: mom

call pnt2mom_nondc(pnt,mom)
call mom2mag(mom,mag)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine pnt2mom(pnt,mom)
!----
! Calculate the seismic moment from the P and T magnitudes by adding the absolute values of the
! two largest eigenvalues and dividing by two (Jost and Herrmann, 1989: Equation 19). This is the
! scalar moment defined by the Global Centroid Moment Tensor project.
!----

implicit none

! Arguments
double precision :: pnt(12), mom

mom = 0.5d0*(abs(pnt(12))+abs(pnt(10)))

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine pnt2mom_nondc(pnt,mom)
!----
! Calculate the seismic moment from the P and T magnitudes by adding the sum of squares of the
! eigenvalues, dividing by two, and taking the square root (Jost and Herrmann, 1989: Equation 20;
! from Silver and Jordan, 1982). This is equivalent to pnt2mom for a double couple source. This is
! the scalar moment defined by the USGS, and the value used for scaling beachballs in GMT psmeca.
!----

implicit none

! Arguments
double precision :: pnt(12), mom

mom = sqrt(0.5d0*(pnt(10)*pnt(10)+pnt(11)*pnt(11)+pnt(12)*pnt(12)))

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine pnt2sdr(pnt,str1,dip1,rak1,str2,dip2,rak2)
!----
! Compute the strike, dip, and rake of the best-fitting double couple source corresponding to a
! set of P, N, and T axes. Calculate for both nodal planes.
!----

use trig, only: r2d, d2r

implicit none

! Arguments
double precision :: pnt(12), str1, dip1, rak1, str2, dip2, rak2

! Local variables
double precision :: slip_vec(3), normal_vec(3), str_vec(3)

! Compute the unit normal and unit slip vectors corresponding to the P and T axes
slip_vec = (pnt(7:9)+pnt(1:3))/sqrt(2.0d0)
normal_vec = (pnt(7:9)-pnt(1:3))/sqrt(2.0d0)

! Convention is that normal vector must point up
if (normal_vec(3).lt.0.0d0) then
    slip_vec = -slip_vec
    normal_vec = -normal_vec
endif

! Compute strike from normal vector
str1 = atan2(normal_vec(1),normal_vec(2))*r2d - 90.0d0
if (str1.lt.0.0d0) then
    str1 = str1 + 360.0d0
endif

! Compute the dip from the normal vector
dip1 = atan2(sqrt(normal_vec(1)**2+normal_vec(2)**2),normal_vec(3))*r2d

! Vector parallel to strike
str_vec(1) = sin(str1*d2r)
str_vec(2) = cos(str1*d2r)
str_vec(3) = 0.0d0

! Compute the rake
rak1 = acos(str_vec(1)*slip_vec(1)+str_vec(2)*slip_vec(2))*r2d
if (str_vec(1)*slip_vec(2)-str_vec(2)*slip_vec(1).lt.0.0d0) then
    rak1 = -rak1
endif

! Compute strike, dip, and rake of other nodal plane
call sdr2sdr(str1,dip1,rak1,str2,dip2,rak2)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine pnt2sv(pnt,slip_vec1,slip_vec2)
!----
! Compute the slip vectors for the best-fitting double couple to P, N, and T axes
!----

implicit none

! Arguments
double precision :: pnt(12), slip_vec1(3), slip_vec2(3)

! Local variables
double precision :: str1, dip1, rak1, str2, dip2, rak2

call pnt2sdr(pnt,str1,dip1,rak1,str2,dip2,rak2)
call sdr2sv(str1,dip1,rak1,slip_vec1)
call sdr2sv(str2,dip2,rak2,slip_vec2)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine pnt2ter(pnt,fth,fss,fno)
!----
! Compute the fraction thrust, strike-slip, and normal component from P, N, and T axes.
!
! Frohlich, C. (1992). Triangle diagrams: ternary graphs to display similarity and diversity of
!     earthquake focal mechanisms. Physics of the Earth and Planetary Interiors, 75, 193-198.
!----

implicit none

! Arguments
double precision :: pnt(12), fth, fss, fno

! Local variables
double precision :: p_pl, n_pl, t_pl

! Compute the plunge of each axis
p_pl = atan(pnt(3)/dsqrt(pnt(1)*pnt(1)+pnt(2)*pnt(2)))
n_pl = atan(pnt(6)/dsqrt(pnt(4)*pnt(4)+pnt(5)*pnt(5)))
t_pl = atan(pnt(9)/dsqrt(pnt(7)*pnt(7)+pnt(8)*pnt(8)))

! Compute the fraction thrust, strike-slip, and normal
fno = dsin(p_pl)*dsin(p_pl)
fss = dsin(n_pl)*dsin(n_pl)
fth = dsin(t_pl)*dsin(t_pl)

return
end

!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!---------------------------------- sdr2xxx -------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!

subroutine sdr2mij(str,dip,rak,mrr,mtt,mpp,mrt,mrp,mtp)
!----
! Compute the unit moment tensor for a double couple source, given the strike, dip, and rake angles.
! Strike is in degrees clockwise from north, dip is in degrees from horizontal, and rake is in
! degrees counter-clockwise from horizontal along the fault plane. The moment tensor is in the
! spherical coordinate system used by the Global Centroid Moment Tensor project.
!----

use trig, only: d2r

implicit none

! Arguments
double precision :: str, dip, rak, mrr, mtt, mpp, mrt, mrp, mtp

! Local variables
double precision :: cs, ss, s2s, c2s, cd, sd, s2d, c2d, cr, sr

! Trigonometric functions of strike, dip, and rake
cs  = dcos(str*d2r)
ss  = dsin(str*d2r)
s2s = dsin(2.0d0*str*d2r)
c2s = dcos(2.0d0*str*d2r)
cd  = dcos(dip*d2r)
sd  = dsin(dip*d2r)
s2d = dsin(2.0d0*dip*d2r)
c2d = dcos(2.0d0*dip*d2r)
cr  = dcos(rak*d2r)
sr  = dsin(rak*d2r)

! Moment tensor components in GCMT convention (r,t,p)
mrr =  (            s2d*sr      )
mtt = -(sd*cr*s2s + s2d*sr*ss*ss)
mpp =  (sd*cr*s2s - s2d*sr*cs*cs)
mrt = -(cd*cr*cs  + c2d*sr*ss   )
mrp =  (cd*cr*ss  - c2d*sr*cs   )
mtp = -(sd*cr*c2s + s2d*sr*ss*cs)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine sdr2pnt(str,dip,rak,pnt)
!----
! Compute the unit P, N, and T axes from a pure double couple source defined by strike, dip, and
! rake angles. There is no moment magnitude information, so the P and T axes should have a value
! of one, and the N axis has a value of zero.
!----

implicit none

! Arguments
double precision :: str, dip, rak, pnt(12)

! Local variables
double precision :: mrr, mtt, mpp, mrt, mrp, mtp

! Convert strike, dip, and rake angles to a moment tensor
call sdr2mij(str,dip,rak,mrr,mtt,mpp,mrt,mrp,mtp)

! Compute eigenvectors and eigenvalues of moment tensor
call mij2pnt(mrr,mtt,mpp,mrt,mrp,mtp,pnt)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine sdr2sdr(str1,dip1,rak1,str2,dip2,rak2)
!----
! Compute the second nodal plane of a double couple source
!----

use trig, only: d2r, r2d

implicit none

! Arguments
double precision :: str1, dip1, rak1, str2, dip2, rak2

! Local variables
double precision :: normal_vec(3), rake_vec(3)

! Compute normal vector of input plane
normal_vec(1) =  dsin(dip1*d2r)*dcos(str1*d2r)
normal_vec(2) = -dsin(dip1*d2r)*dsin(str1*d2r)
normal_vec(3) =  dcos(dip1*d2r)

! Compute rake vector
rake_vec(1) = dcos(rak1*d2r)*dsin(str1*d2r) - dcos(dip1*d2r)*dsin(rak1*d2r)*dcos(str1*d2r)
rake_vec(2) = dcos(rak1*d2r)*dcos(str1*d2r) + dcos(dip1*d2r)*dsin(rak1*d2r)*dsin(str1*d2r)
rake_vec(3) =                                 dsin(dip1*d2r)*dsin(rak1*d2r)

! If rake vector points down, flip it
if (rake_vec(3).lt.0.0d0) then
    rake_vec = -rake_vec
    normal_vec = -normal_vec
endif

! Compute strike of second nodal plane
str2 = datan2(rake_vec(1),rake_vec(2))*r2d - 90.0d0

! Make sure strike is in domain [0,360]
if (str2.gt.360.0d0) then
    str2 = str2 - 360.0d0
endif
if (str2.lt.0.0d0) then
    str2 = str2 + 360.0d0
endif

! Compute dip of second nodal plane
dip2 = datan(dsqrt(rake_vec(1)*rake_vec(1)+rake_vec(2)*rake_vec(2))/rake_vec(3))*r2d

! Compute rake of second nodal plane
rak2 = dacos(normal_vec(1)*dsin(str2*d2r)+normal_vec(2)*dcos(str2*d2r))*r2d

! Check whether rake is positive or negative
if (normal_vec(2)*dsin(str2*d2r)-normal_vec(1)*dcos(str2*d2r).lt.0.0d0) then
    rak2 = -rak2
endif

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine sdr2sv(str,dip,rak,slip_vec)
!----
! Compute the slip vector (east, north, vertical) of the hanging wall relative to the footwall
! corresponding to the strike, dip, and rake.
!----

use trig, only: d2r

implicit none

! Arguments
double precision :: str, dip, rak, slip_vec(3)

! Local variables
double precision :: vec(3)

! Compute slip vector in fault reference frame (x=strike, y=horizontal updip, z=up)
vec(1) = cos(rak*d2r)
vec(2) = sin(rak*d2r)*cos(dip*d2r)
vec(3) = sin(rak*d2r)*sin(dip*d2r)

! Rotate horizontal components to east, north
slip_vec(1) = vec(1)*sin(str*d2r) - vec(2)*cos(str*d2r)
slip_vec(2) = vec(1)*cos(str*d2r) + vec(2)*sin(str*d2r)
slip_vec(3) = vec(3)

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine sdr2ter(str,dip,rak,fth,fss,fno)
!----
! Compute the fraction thrust, strike-slip, and normal component from strike, dip, and rake.
!
! Frohlich, C. (1992). Triangle diagrams: ternary graphs to display similarity and diversity of
!     earthquake focal mechanisms. Physics of the Earth and Planetary Interiors, 75, 193-198.
!----

implicit none

! Arguments
double precision :: str, dip, rak, fth, fss, fno

! Local variables
double precision :: pnt(12)

! Compute the P, N, and T axes for this strike, dip, and rake
call sdr2pnt(str,dip,rak,pnt)

! Compute the fraction thrust, strike-slip, and normal
call pnt2ter(pnt,fth,fss,fno)

return
end subroutine

!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!----------------------------- Moment <-> Magnitude -----------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!

subroutine mom2mag(mom,mag)
!----
! Convert the scalar seismic moment (in Nm) to moment magnitude
! From Kanamori (1977), p. 2984
!----
implicit none
! Arguments
double precision :: mom, mag
! mag = 2.0d0/3.0d0*log10(mom*nm2dynecm)-10.7d0
mag = 2.0d0/3.0d0*(log10(mom*nm2dynecm)-16.101d0)
return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine mag2mom(mag,mom)
!----
! Convert the moment magnitude to the scalar seismic moment (in Nm)
! From Kanamori (1977), p. 2984
!----
implicit none
! Arguments
double precision :: mag, mom
! mom = 10.0d0**((mag+10.7d0)*1.5d0)
mom = 10.0d0**(1.5d0*mag+16.101d0)
mom = mom*dynecm2nm
return
end subroutine

!--------------------------------------------------------------------------------------------------!
!-------------------------------- ANGLE BETWEEN MOMENT TENSORS ------------------------------------!
!--------------------------------------------------------------------------------------------------!

subroutine sdr2kagan(str1,dip1,rak1,str2,dip2,rak2,angle)
implicit none
! Arguments
double precision :: str1, dip1, rak1, str2, dip2, rak2, angle
! Local variables
double precision :: mrr1, mtt1, mpp1, mrt1, mrp1, mtp1, mrr2, mtt2, mpp2, mrt2, mrp2, mtp2
double precision :: mt1(6), mt2(6)
call sdr2mij(str1,dip1,rak1,mrr1,mtt1,mpp1,mrt1,mrp1,mtp1)
call sdr2mij(str2,dip2,rak2,mrr2,mtt2,mpp2,mrt2,mrp2,mtp2)
mt1(1) = mrr1
mt1(2) = mtt1
mt1(3) = mpp1
mt1(4) = mrt1
mt1(5) = mrp1
mt1(6) = mtp1
mt2(1) = mrr2
mt2(2) = mtt2
mt2(3) = mpp2
mt2(4) = mrt2
mt2(5) = mrp2
mt2(6) = mtp2
call kaganangle(mt1,mt2,angle)
return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine mij2kagan(mrr1,mtt1,mpp1,mrt1,mrp1,mtp1,mrr2,mtt2,mpp2,mrt2,mrp2,mtp2,angle)
implicit none
! Arguments
double precision :: mrr1, mtt1, mpp1, mrt1, mrp1, mtp1, mrr2, mtt2, mpp2, mrt2, mrp2, mtp2, angle
! Local variables
double precision :: mt1(6), mt2(6)
mt1(1) = mrr1
mt1(2) = mtt1
mt1(3) = mpp1
mt1(4) = mrt1
mt1(5) = mrp1
mt1(6) = mtp1
mt2(1) = mrr2
mt2(2) = mtt2
mt2(3) = mpp2
mt2(4) = mrt2
mt2(5) = mrp2
mt2(6) = mtp2
call kaganangle(mt1,mt2,angle)
return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine kaganangle(mt1,mt2,angle)

use trig, only: r2d

implicit none
double precision :: mt1(6), mt2(6), angle
double precision :: pnt1(12), pnt2(12)
double precision :: mat1(3,3), mat2(3,3), u(3,3), w, qw(4), qq
integer :: i

call mij2pnt(mt1(1),mt1(2),mt1(3),mt1(4),mt1(5),mt1(6),pnt1)
call mij2pnt(mt2(1),mt2(2),mt2(3),mt2(4),mt2(5),mt2(6),pnt2)

! Transpose of first eigenvector matrix
mat1(1,1) = pnt1(1)
mat1(1,2) = pnt1(2)
mat1(1,3) = pnt1(3)
mat1(2,1) = pnt1(4)
mat1(2,2) = pnt1(5)
mat1(2,3) = pnt1(6)
mat1(3,1) = pnt1(7)
mat1(3,2) = pnt1(8)
mat1(3,3) = pnt1(9)

! Second eigenvector matrix
mat2(1,1) = pnt2(1)
mat2(2,1) = pnt2(2)
mat2(3,1) = pnt2(3)
mat2(1,2) = pnt2(4)
mat2(2,2) = pnt2(5)
mat2(3,2) = pnt2(6)
mat2(1,3) = pnt2(7)
mat2(2,3) = pnt2(8)
mat2(3,3) = pnt2(9)

! Multiply matrices
u(1,1) = mat1(1,1)*mat2(1,1) + mat1(1,2)*mat2(2,1) + mat1(1,3)*mat2(3,1)
u(1,2) = mat1(1,1)*mat2(1,2) + mat1(1,2)*mat2(2,2) + mat1(1,3)*mat2(3,2)
u(1,3) = mat1(1,1)*mat2(1,3) + mat1(1,2)*mat2(2,3) + mat1(1,3)*mat2(3,3)
u(2,1) = mat1(2,1)*mat2(1,1) + mat1(2,2)*mat2(2,1) + mat1(2,3)*mat2(3,1)
u(2,2) = mat1(2,1)*mat2(1,2) + mat1(2,2)*mat2(2,2) + mat1(2,3)*mat2(3,2)
u(2,3) = mat1(2,1)*mat2(1,3) + mat1(2,2)*mat2(2,3) + mat1(2,3)*mat2(3,3)
u(3,1) = mat1(3,1)*mat2(1,1) + mat1(3,2)*mat2(2,1) + mat1(3,3)*mat2(3,1)
u(3,2) = mat1(3,1)*mat2(1,2) + mat1(3,2)*mat2(2,2) + mat1(3,3)*mat2(3,2)
u(3,3) = mat1(3,1)*mat2(1,3) + mat1(3,2)*mat2(2,3) + mat1(3,3)*mat2(3,3)

! Calculate quaternion
w = 0.5d0*sqrt(1.0d0 + u(1,1) + u(2,2) + u(3,3))
qw(1) = w
qw(2) = (u(3,2)-u(2,3))/(4.0d0*w)
qw(3) = (u(1,3)-u(3,1))/(4.0d0*w)
qw(4) = (u(2,1)-u(1,2))/(4.0d0*w)

! Take maximum value and use this to calculate the angle
qq = qw(1)
do i = 2,4
    if (abs(qw(i)).gt.abs(qq)) then
        qq = qw(i)
    endif
enddo

angle = 2.0d0*acos(abs(qq))*r2d

return
end subroutine

!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!-------------------------------- EMPIRICAL RELATIONS ---------------------------------------------!
!--------------------------------------------------------------------------------------------------!
!--------------------------------------------------------------------------------------------------!

subroutine empirical(mag,wid,len,relation_input,fault_type)
!----
! Compute the fault width (down-dip) and length (along-strike) from the magnitude for a particular
! empirical relation.
!----

use io, only: stderr, stdout

implicit none

! Arguments
double precision :: mag, wid, len
character(len=*) :: relation_input, fault_type

! Local variables
integer :: i
logical :: printRelation
double precision :: mom, log10mom
double precision :: len_surf_rupt(4), len_total(4), wid_total(4), area(4), &
                    slip_max(4), slip_avg(4)
character(len=32) :: relation_name

! Initialize return values
wid = 0.0d0
len = 0.0d0

! Initialize values
wid_total = 0.0d0
len_total = 0.0d0

! If relation_name ends with ":print", then print all parameter information for empirical relation
! Otherwise, extract the length and width corresponding to the relation and fault type only
i = index(relation_input,':print')
if (i.eq.0) then
    relation_name = relation_input
    printRelation = .false.
else
    relation_name = relation_input(1:i-1)
    printRelation = .true.
endif

! Determine earthquake parameters and print if requested
if (relation_name.eq.'wells_coppersmith_94'.or.relation_name.eq.'WC') then
    ! Wells, D.L., Coppersmith, K.J. (1994). New empirical relationships among magnitude, rupture
    !   length, rupture width, rupture area, and surface displacement. Bulletin of the Seismological
    !   Society of America, 84, 974–1002.

    ! 1=ss  2=th  3=no  4=all
    ! Total subsurface rupture length
    len_total(1) = 10.0d0 ** (-2.57d0 + 0.62d0*mag)         ! a: +/-0.12,  b: +/-0.02
    len_total(2) = 10.0d0 ** (-2.42d0 + 0.58d0*mag)         ! a: +/-0.21,  b: +/-0.03
    len_total(3) = 10.0d0 ** (-1.88d0 + 0.50d0*mag)         ! a: +/-0.37,  b: +/-0.06
    len_total(4) = 10.0d0 ** (-2.44d0 + 0.59d0*mag)         ! a: +/-0.11,  b: +/-0.02

    ! Downdip rupture width
    wid_total(1) = 10.0d0 ** (-0.76d0 + 0.27d0*mag)         ! a: +/-0.12,  b: +/-0.02
    wid_total(2) = 10.0d0 ** (-1.61d0 + 0.41d0*mag)         ! a: +/-0.20,  b: +/-0.03
    wid_total(3) = 10.0d0 ** (-1.14d0 + 0.35d0*mag)         ! a: +/-0.28,  b: +/-0.05
    wid_total(4) = 10.0d0 ** (-1.01d0 + 0.32d0*mag)         ! a: +/-0.10,  b: +/-0.02

    if (printRelation) then
        ! Surface rupture length
        len_surf_rupt(1) = 10.0d0 ** (-3.55d0 + 0.74d0*mag) ! a: +/-0.37,  b: +/-0.05
        len_surf_rupt(2) = 10.0d0 ** (-2.86d0 + 0.63d0*mag) ! a: +/-0.55,  b: +/-0.08
        len_surf_rupt(3) = 10.0d0 ** (-2.01d0 + 0.50d0*mag) ! a: +/-0.65,  b: +/-0.10
        len_surf_rupt(4) = 10.0d0 ** (-3.22d0 + 0.69d0*mag) ! a: +/-0.27,  b: +/-0.04

        ! Total rupture area
        area(1) = 10.0d0 ** (-3.42d0 + 0.90d0*mag)          ! a: +/-0.18,  b: +/-0.03
        area(2) = 10.0d0 ** (-3.99d0 + 0.98d0*mag)          ! a: +/-0.36,  b: +/-0.06
        area(3) = 10.0d0 ** (-2.87d0 + 0.82d0*mag)          ! a: +/-0.50,  b: +/-0.08
        area(4) = 10.0d0 ** (-3.49d0 + 0.91d0*mag)          ! a: +/-0.16,  b: +/-0.03

        ! Maximum slip
        slip_max(1) = 10.0d0 ** (-7.03d0 + 1.03d0*mag)      ! a: +/-0.55,  b: +/-0.08
        slip_max(2) = 10.0d0 ** (-1.84d0 + 0.29d0*mag)      ! a: +/-1.14,  b: +/-0.17
        slip_max(3) = 10.0d0 ** (-5.90d0 + 0.89d0*mag)      ! a: +/-1.18,  b: +/-0.18
        slip_max(4) = 10.0d0 ** (-5.46d0 + 0.82d0*mag)      ! a: +/-0.51,  b: +/-0.08

        ! Average slip
        slip_avg(1) = 10.0d0 ** (-6.32d0 + 0.90d0*mag)      ! a: +/-0.61,  b: +/-0.09
        slip_avg(2) = 10.0d0 ** (-0.74d0 + 0.08d0*mag)      ! a: +/-1.40,  b: +/-0.21
        slip_avg(3) = 10.0d0 ** (-4.45d0 + 0.63d0*mag)      ! a: +/-1.59,  b: +/-0.24
        slip_avg(4) = 10.0d0 ** (-4.80d0 + 0.69d0*mag)      ! a: +/-0.57,  b: +/-0.08

        write(stdout,*) 'Scaling Relation: Wells and Coppersmith, BSSA (1994)'
        write(stdout,*)
        write(stdout,*) 'Description:'
        write(stdout,*) '"A worldwide data base of source parameters for 421 historical earthquakes ',&
                   'is compiled for this study.'
        write(stdout,*) ' The data include shallow-focus (hypocentral depth less than 40 km), ',&
                   'continental interplate or intraplate'
        write(stdout,*) ' earthquakes of magnitudes greater than approximately 4.5. Earthquakes ',&
                   'associated with subduction zones,'
        write(stdout,*) ' both plate interface earthquakes and those occurring within oceanic slabs, ',&
                   'are excluded."'
        write(stdout,*)
        write(stdout,5062) 'Magnitude:',mag
        write(stdout,*)
        write(stdout,*) 'Total subsurface length (km)'
        write(stdout,5102) 'strike-slip:',len_total(1)
        write(stdout,5102) 'thrust:     ',len_total(2)
        write(stdout,5102) 'normal:     ',len_total(3)
        write(stdout,5102) 'all:        ',len_total(4)
        write(stdout,*) 'Total down-dip width (km)'
        write(stdout,5102) 'strike-slip:',wid_total(1)
        write(stdout,5102) 'thrust:     ',wid_total(2)
        write(stdout,5102) 'normal:     ',wid_total(3)
        write(stdout,5102) 'all:        ',wid_total(4)
        write(stdout,*) 'Surface rupture length (km)'
        write(stdout,5102) 'strike-slip:',len_surf_rupt(1)
        write(stdout,5102) 'thrust:     ',len_surf_rupt(2)
        write(stdout,5102) 'normal:     ',len_surf_rupt(3)
        write(stdout,5102) 'all:        ',len_surf_rupt(4)
        write(stdout,*) 'Total rupture area (km^2)'
        write(stdout,5101) 'strike-slip:',area(1)
        write(stdout,5101) 'thrust:     ',area(2)
        write(stdout,5101) 'normal:     ',area(3)
        write(stdout,5101) 'all:        ',area(4)
        write(stdout,*) 'Maximum slip (m)'
        write(stdout,5103) 'strike-slip:',slip_max(1)
        write(stdout,5103) 'thrust:     ',slip_max(2)
        write(stdout,5103) 'normal:     ',slip_max(3)
        write(stdout,5103) 'all:        ',slip_max(4)
        write(stdout,*) 'Average slip (m)'
        write(stdout,5103) 'strike-slip:',slip_avg(1)
        write(stdout,5103) 'thrust:     ',slip_avg(2)
        write(stdout,5103) 'normal:     ',slip_avg(3)
        write(stdout,5103) 'all:        ',slip_avg(4)
    endif

    ! Return total fault length and width
    if (fault_type.eq.'strike-slip'.or.fault_type.eq.'ss') then
        len = len_total(1)
        wid = wid_total(1)
    elseif (fault_type.eq.'thrust'.or.fault_type.eq.'th') then
        len = len_total(2)
        wid = wid_total(2)
    elseif (fault_type.eq.'normal'.or.fault_type.eq.'no') then
        len = len_total(3)
        wid = wid_total(3)
    else
        len = len_total(4)
        wid = wid_total(4)
    endif

elseif (relation_name.eq.'mai_beroza_00'.or.relation_name.eq.'MB') then
    ! Mai, P.M., Beroza, G.C. (2000). Source scaling properties from finite- fault-rupture models.
    !   Bulletin of the Seismological Society of America, 90, 604-615.
    call mag2mom(mag,mom)
    log10mom = log10(mom)

    ! 1=ss  2=th  3=no  4=all
    ! Effective subsurface rupture length
    len_total(1) = 10.0d0**(-6.31d0+0.40d0*log10mom)          ! a: +/-1.15,  b: +/-0.06
    len_total(2) = 10.0d0**(-6.39d0+0.40d0*log10mom)          ! a: +/-1.04,  b: +/-0.05
    len_total(3) = 10.0d0**(-6.39d0+0.40d0*log10mom)          ! a: +/-1.04,  b: +/-0.05
    len_total(4) = 10.0d0**(-6.13d0+0.39d0*log10mom)          ! a: +/-0.74,  b: +/-0.04

    ! Effective downdip rupture width
    wid_total(1) = 10.0d0**(-2.18d0+0.17d0*log10mom)          ! a: +/-1.09,  b: +/-0.06
    wid_total(2) = 10.0d0**(-5.51d0+0.35d0*log10mom)          ! a: +/-0.81,  b: +/-0.04
    wid_total(3) = 10.0d0**(-5.51d0+0.35d0*log10mom)          ! a: +/-0.81,  b: +/-0.04
    wid_total(4) = 10.0d0**(-5.05d0+0.32d0*log10mom)          ! a: +/-0.74,  b: +/-0.04

    if (printRelation) then
        ! Effective rupture area
        area(1) = 10.0d0**(-8.49d0+0.57d0*log10mom)            ! a: +/-1.85,  b: +/-0.10
        area(2) = 10.0d0**(-11.90d0+0.75d0*log10mom)           ! a: +/-1.67,  b: +/-0.09
        area(3) = 10.0d0**(-11.90d0+0.75d0*log10mom)           ! a: +/-1.67,  b: +/-0.09
        area(4) = 10.0d0**(-11.18d0+0.72d0*log10mom)           ! a: +/-1.18,  b: +/-0.06

        ! Effective slip
        slip_avg(1) = 10.0d0**(-6.03d0+0.43d0*log10mom)/1.0d2  ! a: +/-0.61,  b: +/-0.09
        slip_avg(2) = 10.0d0**(-2.62d0+0.25d0*log10mom)/1.0d2  ! a: +/-1.40,  b: +/-0.21
        slip_avg(3) = 10.0d0**(-2.62d0+0.25d0*log10mom)/1.0d2  ! a: +/-1.59,  b: +/-0.24
        slip_avg(4) = 10.0d0**(-3.34d0+0.29d0*log10mom)/1.0d2  ! a: +/-0.57,  b: +/-0.08

        write(stdout,*) 'Scaling Relation: Mai and Beroza, BSSA (2000)'
        write(stdout,*)
        write(stdout,*) 'Description:'
        write(stdout,*) '"Finite-source images of earthquake rupture show that fault slip is spatially ',&
                   'variable at all resolvable'
        write(stdout,*) ' scales. In this study we develop scaling laws that account for this variability by ',&
                   'measuring effective'
        write(stdout,*) ' fault dimensions derived from the autocorrelation of the slip function for ',&
                   '31 published slip models '
        write(stdout,*) ' of 18 earthquakes, 8 strike-slip events, and 10 dip-slip (reverse, normal, ',&
                   'or oblique) events."'
        write(stdout,*)
        write(stdout,5062) 'Magnitude:',mag
        write(stdout,*)
        write(stdout,*) 'Effective subsurface length (km)'
        write(stdout,5102) 'strike-slip:',len_total(1)
        write(stdout,5102) 'thrust:     ',len_total(2)
        write(stdout,5102) 'normal:     ',len_total(3)
        write(stdout,5102) 'all:        ',len_total(4)
        write(stdout,*) 'Effective down-dip width (km)'
        write(stdout,5102) 'strike-slip:',wid_total(1)
        write(stdout,5102) 'thrust:     ',wid_total(2)
        write(stdout,5102) 'normal:     ',wid_total(3)
        write(stdout,5102) 'all:        ',wid_total(4)
        write(stdout,*) 'Effective rupture area (km^2)'
        write(stdout,5101) 'strike-slip:',area(1)
        write(stdout,5101) 'thrust:     ',area(2)
        write(stdout,5101) 'normal:     ',area(3)
        write(stdout,5101) 'all:        ',area(4)
        write(stdout,*) 'Effective slip (m)'
        write(stdout,5103) 'strike-slip:',slip_avg(1)
        write(stdout,5103) 'thrust:     ',slip_avg(2)
        write(stdout,5103) 'normal:     ',slip_avg(3)
        write(stdout,5103) 'all:        ',slip_avg(4)
    endif

    ! Return effective fault length and width
    if (fault_type.eq.'strike-slip'.or.fault_type.eq.'ss') then
        len = len_total(1)
        wid = wid_total(1)
    elseif (fault_type.eq.'thrust'.or.fault_type.eq.'th') then
        len = len_total(2)
        wid = wid_total(2)
    elseif (fault_type.eq.'normal'.or.fault_type.eq.'no') then
        len = len_total(3)
        wid = wid_total(3)
    else
        len = len_total(4)
        wid = wid_total(4)
    endif

elseif (relation_name.eq.'blaser_et_al_10'.or.relation_name.eq.'B') then
    ! Blaser, L., Kruger, F., Ohrnberger, M., Scherbaum, F. (2010). Scaling relations of earthquake
    !   source parameter estimates with special focus on subduction environment. Bulletin of the
    !   Seismological Society of America, vol. 100, no. 6, pp. 2914-2926.

    ! 1=ss  2=th  3=no  4=all
    ! Subsurface rupture length
    len_total(1) = 10.0d0**(-2.69d0+0.64d0*mag)     ! a: +/-0.11,  b: +/-0.02
    len_total(2) = 10.0d0**(-2.37d0+0.57d0*mag)     ! a: +/-0.13,  b: +/-0.02
    len_total(3) = 10.0d0**(-1.91d0+0.52d0*mag)     ! a: +/-0.29,  b: +/-0.04
    len_total(4) = 10.0d0**(-2.31d0+0.57d0*mag)     ! a: +/-0.08,  b: +/-0.01

    ! Downdip rupture width
    wid_total(1) = 10.0d0**(-1.12d0+0.33d0*mag)     ! a: +/-0.12,  b: +/-0.02
    wid_total(2) = 10.0d0**(-1.86d0+0.46d0*mag)     ! a: +/-0.12,  b: +/-0.02
    wid_total(3) = 10.0d0**(-1.20d0+0.36d0*mag)     ! a: +/-0.25,  b: +/-0.04
    wid_total(4) = 10.0d0**(-1.56d0+0.41d0*mag)     ! a: +/-0.09,  b: +/-0.01

    if (printRelation) then
        write(stdout,*) 'Scaling Relation: Blaser et al., BSSA (2010)'
        write(stdout,*)
        write(stdout,*) 'Description:'
        write(stdout,*) '"Within this study, we compiled a large database of source parameter ',&
                        'estimates of 283 earthquakes....'
        write(stdout,*) ' We distinguish between reverse faulting subduction zone events, ',&
                        'neighboring outer-rise events of'
        write(stdout,*) ' normal faulting slip type and oceanic strike-slip faulting earthquakes."'
        write(stdout,*)
        write(stdout,5062) 'Magnitude:',mag
        write(stdout,*)
        write(stdout,*) 'Subsurface length (km)'
        write(stdout,5102) 'strike-slip:',len_total(1)
        write(stdout,5102) 'thrust:     ',len_total(2)
        write(stdout,5102) 'normal:     ',len_total(3)
        write(stdout,5102) 'all:        ',len_total(4)
        write(stdout,*) 'Down-dip width (km)'
        write(stdout,5102) 'strike-slip:',wid_total(1)
        write(stdout,5102) 'thrust:     ',wid_total(2)
        write(stdout,5102) 'normal:     ',wid_total(3)
        write(stdout,5102) 'all:        ',wid_total(4)
    endif

    if (fault_type.eq.'strike-slip'.or.fault_type.eq.'ss') then
        len = len_total(1)
        wid = wid_total(1)
    elseif (fault_type.eq.'thrust'.or.fault_type.eq.'th') then
        len = len_total(2)
        wid = wid_total(2)
    elseif (fault_type.eq.'normal'.or.fault_type.eq.'no') then
        len = len_total(3)
        wid = wid_total(3)
    else
        len = len_total(4)
        wid = wid_total(4)
    endif

elseif (relation_name.eq.'yen_ma_11'.or.relation_name.eq.'YM') then
    ! Yen, Y.-T., Ma, K.-F. (2011). Source-scaling relationship for M 4.6-8.9 earthquakes,
    !   specifically for earthquakes in the collision zone of Taiwan. Bulletin of the Seismological
    !   Society of America, 101, 464-481.
    call mag2mom(mag,mom)
    log10mom = log10(mom)

    ! 1=ss  2=th  3=no  4=all
    ! Effective subsurface rupture length
    len_total(1) = 10.0d0**(-8.11d0+0.50d0*log10mom)     ! a: +/-1.20,  b: +/-0.07
    len_total(2) = 10.0d0**(-6.66d0+0.42d0*log10mom)     ! a: +/-1.05,  b: +/-0.06
    len_total(3) = 10.0d0**(-6.66d0+0.42d0*log10mom)     ! a: +/-1.05,  b: +/-0.06
    len_total(4) = 10.0d0**(-7.46d0+0.47d0*log10mom)     ! a: +/-0.77,  b: +/-0.04

    ! Effective downdip rupture width
    wid_total(1) = 10.0d0**(-6.67d0+0.42d0*log10mom)     ! a: +/-1.38,  b: +/-0.08
    wid_total(2) = 10.0d0**(-5.76d0+0.37d0*log10mom)     ! a: +/-1.30,  b: +/-0.07
    wid_total(3) = 10.0d0**(-5.76d0+0.37d0*log10mom)     ! a: +/-1.30,  b: +/-0.07
    wid_total(4) = 10.0d0**(-6.30d0+0.40d0*log10mom)     ! a: +/-0.90,  b: +/-0.05

    if (printRelation) then
        ! Effective rupture area
        area(1) = 10.0d0**(-14.77d0+0.92d0*log10mom)         ! a: +/-2.46,  b: +/-0.14
        area(2) = 10.0d0**(-12.45d0+0.80d0*log10mom)         ! a: +/-2.32,  b: +/-0.13
        area(3) = 10.0d0**(-12.45d0+0.80d0*log10mom)         ! a: +/-2.32,  b: +/-0.13
        area(4) = 10.0d0**(-13.79d0+0.87d0*log10mom)         ! a: +/-1.63,  b: +/-0.09

        ! Effective slip
        slip_avg(1) = 10.0d0**( 0.36d0+0.08d0*log10mom)/1.0d2      ! a: +/-2.47,  b: +/-0.14
        slip_avg(2) = 10.0d0**(-2.01d0+0.20d0*log10mom)/1.0d2      ! a: +/-2.32,  b: +/-0.13
        slip_avg(3) = 10.0d0**(-2.01d0+0.20d0*log10mom)/1.0d2      ! a: +/-2.32,  b: +/-0.13
        slip_avg(4) = 10.0d0**(-0.65d0+0.13d0*log10mom)/1.0d2      ! a: +/-1.64,  b: +/-0.09

        write(stdout,*) 'Scaling Relation: Yen and Ma, BSSA (2011)'
        write(stdout,*)
        write(stdout,*) 'Description:'
        write(stdout,*) '"We investigated the source scaling of earthquakes (Mw 4.6–8.9), mostly ',&
                        'from the Taiwan orogenic belt,'
        write(stdout,*) ' and made a global compilation of source parameters to examine the ',&
                        'scaling self-similarity. Finite-fault'
        write(stdout,*) ' slip models (12 dip-slip and 7 strike-slip) using mainly dense ',&
                        'strong-motion data and teleseismic data '
        write(stdout,*) ' from Taiwan were utilized. Seven additional earthquakes (M >7) were ',&
                        'included for further examination'
        write(stdout,*) ' of scaling of large events."'
        write(stdout,*)
        write(stdout,5062) 'Magnitude:',mag
        write(stdout,*)
        write(stdout,*) 'Effective subsurface length (km)'
        write(stdout,5102) 'strike-slip:',len_total(1)
        write(stdout,5102) 'thrust:     ',len_total(2)
        write(stdout,5102) 'normal:     ',len_total(3)
        write(stdout,5102) 'all:        ',len_total(4)
        write(stdout,*) 'Effective down-dip width (km)'
        write(stdout,5102) 'strike-slip:',wid_total(1)
        write(stdout,5102) 'thrust:     ',wid_total(2)
        write(stdout,5102) 'normal:     ',wid_total(3)
        write(stdout,5102) 'all:        ',wid_total(4)
        write(stdout,*) 'Effective rupture area (km^2)'
        write(stdout,5101) 'strike-slip:',area(1)
        write(stdout,5101) 'thrust:     ',area(2)
        write(stdout,5101) 'normal:     ',area(3)
        write(stdout,5101) 'all:        ',area(4)
        write(stdout,*) 'Effective slip (m)'
        write(stdout,5103) 'strike-slip:',slip_avg(1)
        write(stdout,5103) 'thrust:     ',slip_avg(2)
        write(stdout,5103) 'normal:     ',slip_avg(3)
        write(stdout,5103) 'all:        ',slip_avg(4)
    endif

    ! Return effective fault length and width
    if (fault_type.eq.'strike-slip'.or.fault_type.eq.'ss') then
        len = len_total(1)
        wid = wid_total(1)
    elseif (fault_type.eq.'thrust'.or.fault_type.eq.'th') then
        len = len_total(2)
        wid = wid_total(2)
    elseif (fault_type.eq.'normal'.or.fault_type.eq.'no') then
        len = len_total(3)
        wid = wid_total(3)
    else
        len = len_total(4)
        wid = wid_total(4)
    endif

elseif (relation_name.eq.'allen_hayes_17'.or.relation_name.eq.'AH') then
    ! Allen, T.I., Hayes, G.P. (2017). Alternative rupture‐scaling relationships for subduction
    !   interface and other offshore environments. Bulletin of the Seismological Society of America
    !   107, 1240–1253.

    ! 1=ss  2=th  3=no  4=all
    ! Effective subsurface rupture length
    len_total(1) = 10.0d0**(-2.81d0+0.63d0*mag)
    len_total(2) = 10.0d0**(-2.90d0+0.63d0*mag)
    len_total(3) = 10.0d0**(-2.87d0+0.63d0*mag)
    len_total(4) = 10.0d0**(-3.03d0+0.63d0*mag)

    ! Effective downdip rupture width
    wid_total(1) = 10.0d0**(-1.39d0+0.35d0*mag)
    if (mag.le.8.67d0) then
        wid_total(2) = 10.0d0**(-1.91d0+0.48d0*mag)
    else
        wid_total(2) = 10.0d0**( 2.29d0+0.00d0*mag)
    endif
    wid_total(3) = 10.0d0**(-1.18d0+0.35d0*mag)
    wid_total(4) = 10.0d0**(-1.01d0+0.35d0*mag)

    if (printRelation) then
        ! Effective rupture area
        area(1) = 10.0d0**(-4.04d0+0.96d0*mag)
        if (mag.le.8.67d0) then
            area(2) = 10.0d0**(-5.62d0+1.22d0*mag)
        else
            area(2) = 10.0d0**( 2.23d0+0.31d0*mag)
        endif
        area(3) = 10.0d0**(-3.89d0+0.96d0*mag)
        area(4) = 10.0d0**(-3.89d0+0.87d0*mag)

        ! Maximum slip
        slip_max(1) = 10.0d0**(-4.39d0+0.71d0*mag)
        slip_max(2) = 10.0d0**(-4.94d0+0.71d0*mag)
        slip_max(3) = 10.0d0**(-4.58d0+0.71d0*mag)
        slip_max(4) = 10.0d0**(-4.73d0+0.71d0*mag)

        ! Average slip
        slip_avg(1) = 10.0d0**(-4.52d0+0.66d0*mag)
        slip_avg(2) = 10.0d0**(-5.05d0+0.66d0*mag)
        slip_avg(3) = 10.0d0**(-4.70d0+0.66d0*mag)
        slip_avg(4) = 10.0d0**(-4.81d0+0.66d0*mag)

        write(stdout,*) 'Scaling Relation: Allen and Hayes, BSSA (2017)'
        write(stdout,*)
        write(stdout,*) 'Description:'
        write(stdout,*) '"Alternative fault-rupture-scaling relationships are developed for Mw 7.1-',&
                        '9.5 subduction interface '
        write(stdout,*) ' earthquakes using a new database of consistently derived finite-fault ',&
                        'rupture models from '
        write(stdout,*) ' teleseismic inversion....'
        write(stdout,*) ' Fault-rupture-scaling relationships are also developed for [Mw 7.2-8.7] ',&
                        'intraslab (within the'
        write(stdout,*) ' subducting slab), extensional outer-rise and offshore strike-slip',&
                        'environments."'
        write(stdout,*)
        write(stdout,5062) 'Magnitude:',mag
        write(stdout,*)
        write(stdout,*) 'Effective subsurface length (km)'
        write(stdout,5102) 'strike-slip:',len_total(1)
        write(stdout,5102) 'thrust:     ',len_total(2)
        write(stdout,5102) 'normal:     ',len_total(3)
        write(stdout,5102) 'all:        ',len_total(4)
        write(stdout,*) 'Effective down-dip width (km)'
        write(stdout,5102) 'strike-slip:',wid_total(1)
        write(stdout,5102) 'thrust:     ',wid_total(2)
        write(stdout,5102) 'normal:     ',wid_total(3)
        write(stdout,5102) 'all:        ',wid_total(4)
        write(stdout,*) 'Effective rupture area (km^2)'
        write(stdout,5101) 'strike-slip:',area(1)
        write(stdout,5101) 'thrust:     ',area(2)
        write(stdout,5101) 'normal:     ',area(3)
        write(stdout,5101) 'all:        ',area(4)
        write(stdout,*) 'Maximum slip (m)'
        write(stdout,5103) 'strike-slip:',slip_max(1)
        write(stdout,5103) 'thrust:     ',slip_max(2)
        write(stdout,5103) 'normal:     ',slip_max(3)
        write(stdout,5103) 'all:        ',slip_max(4)
        write(stdout,*) 'Average slip (m)'
        write(stdout,5103) 'strike-slip:',slip_avg(1)
        write(stdout,5103) 'thrust:     ',slip_avg(2)
        write(stdout,5103) 'normal:     ',slip_avg(3)
        write(stdout,5103) 'all:        ',slip_avg(4)
    endif

    ! Return effective fault length and width
    if (fault_type.eq.'strike-slip'.or.fault_type.eq.'ss') then
        len = len_total(1)
        wid = wid_total(1)
    elseif (fault_type.eq.'thrust'.or.fault_type.eq.'th') then
        len = len_total(2)
        wid = wid_total(2)
    elseif (fault_type.eq.'normal'.or.fault_type.eq.'no') then
        len = len_total(3)
        wid = wid_total(3)
    else
        len = len_total(4)
        wid = wid_total(4)
    endif

else
    write(stderr,*) 'empirical: no relation named "',trim(relation_name),'"; returning zeros'
    len = 0.0d0
    wid = 0.0d0
endif

5062 format(X,A,F6.2)
5101 format(3X,A,F10.1)
5102 format(3X,A,F10.2)
5103 format(3X,A,F10.3)

return
end subroutine

end module


      subroutine cg(nm,n,ar,ai,wr,wi,matz,zr,zi,fv1,fv2,fv3,ierr)
c
      integer n,nm,is1,is2,ierr,matz
      double precision ar(nm,n),ai(nm,n),wr(n),wi(n),zr(nm,n),zi(nm,n),
     x       fv1(n),fv2(n),fv3(n)
c
c     this subroutine calls the recommended sequence of
c     subroutines from the eigensystem subroutine package (eispack)
c     to find the eigenvalues and eigenvectors (if desired)
c     of a complex general matrix.
c
c     on input
c
c        nm  must be set to the row dimension of the two-dimensional
c        array parameters as declared in the calling program
c        dimension statement.
c
c        n  is the order of the matrix  a=(ar,ai).
c
c        ar  and  ai  contain the real and imaginary parts,
c        respectively, of the complex general matrix.
c
c        matz  is an integer variable set equal to zero if
c        only eigenvalues are desired.  otherwise it is set to
c        any non-zero integer for both eigenvalues and eigenvectors.
c
c     on output
c
c        wr  and  wi  contain the real and imaginary parts,
c        respectively, of the eigenvalues.
c
c        zr  and  zi  contain the real and imaginary parts,
c        respectively, of the eigenvectors if matz is not zero.
c
c        ierr  is an integer output variable set equal to an error
c           completion code described in the documentation for comqr
c           and comqr2.  the normal completion code is zero.
c
c        fv1, fv2, and  fv3  are temporary storage arrays.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (n .le. nm) go to 10
      ierr = 10 * n
      go to 50
c
   10 call  cbal(nm,n,ar,ai,is1,is2,fv1)
      call  corth(nm,n,is1,is2,ar,ai,fv2,fv3)
      if (matz .ne. 0) go to 20
c     .......... find eigenvalues only ..........
      call  comqr(nm,n,is1,is2,ar,ai,wr,wi,ierr)
      go to 50
c     .......... find both eigenvalues and eigenvectors ..........
   20 call  comqr2(nm,n,is1,is2,fv2,fv3,ar,ai,wr,wi,zr,zi,ierr)
      if (ierr .ne. 0) go to 50
      call  cbabk2(nm,n,is1,is2,fv1,n,zr,zi)
   50 return
      end


module param
!integer(4), parameter :: nx = 51
!integer(4), parameter :: ny = 51
integer(4), parameter :: nx=500
integer(4), parameter :: ny=500
      real, dimension(0:ny+1,0:nx+1) :: hzero
      real, dimension(0:ny+1,0:nx+1) :: h
      real, dimension(0:ny+1,0:nx+1) :: eta
      real, dimension(0:ny+1,0:nx+1) :: etan
      real, dimension(0:ny+1,0:nx+1) :: u
      real, dimension(0:ny+1,0:nx+1) :: un
      real, dimension(0:ny+1,0:nx+1) :: v
      real, dimension(0:ny+1,0:nx+1) :: vn
      real :: dt
      real :: dx
      real :: dy
      real :: g
      real :: eps
      integer :: j
      integer :: k
      integer, dimension(0:ny+1,0:nx+1) :: wet
      real :: hmin
end module param


module gyro
!!---------------------------------------------------------------------------------------------------------------------
!
!			see arXiv:1710.03204v2
!	or
!			Souza et al., PRB 97 035158 (2018)
!!---------------------------------------------------------------------------------------------------------------------

	use constants,			only:		dp
	use statistics,			only:		fd_stat_deriv
	use matrix_math,		only:		convert_tens_to_vect, &
										crossP
	use wann_interp,		only:		get_kubo_curv
	use omp_lib

	implicit none

	public 						::		get_gyro_D, get_gyro_Dw,	&
										get_gyro_C, 				&
										get_gyro_K
	private

	save

	logical						::		d_warning	=	.False.

contains

	function get_gyro_K(V_ka, m_a, fd_distrib) result(K_ab)
		real(dp),		intent(in)			::		m_a(:,:),	fd_distrib(:,:)
		complex(dp),	intent(in)			::		V_ka(:,:,:)
		complex(dp),	allocatable			::		K_ab(:,:,:)
		complex(dp)							::		tens(3,3)
		integer								::		n, b, n_wf, n_ef, ef_idx
		!
		!	m_a is magnetization
		!
		!	can we use equation (15) for the orbital magnetization
		!
		n_wf	=	size(fd_distrib,2)
		n_ef	=	size(fd_distrib,1)
		allocate(	K_ab(	3,3,	n_ef	))
		K_ab	=	0.0_dp
		!
		!$OMP PARALLEL DO  DEFAULT(none) 				&
		!$OMP PRIVATE(tens, b, ef_idx)					&
		!$OMP SHARED(n_wf, n_ef, V_ka, m_a, fd_distrib)	&
		!$OMP REDUCTION(+: K_ab)
		do n = 1, n_wf
			!
			!
			tens = 0.0_dp
			do b = 1, 3
				tens(:,b)	=	tens(:,b)	+	V_ka(:,n,n) * m_a(b,n)
			end do
			!
			do ef_idx	= 1, n_ef
				K_ab(:,:,ef_idx)	=	K_ab(:,:,ef_idx)	+	tens(:,:)	* fd_distrib(ef_idx,n)
			end do
			!
			!
		end do
		!$OMP END PARALLEL DO
		!
		return
	end function

	function get_gyro_D(en_k, V_ka, Om_kab, fd_deriv) result(D_ab)
		!
		!	see eq.(2) of PRB 97 035158 (2018)
		!
		real(dp),						intent(in)			::		en_k(:), fd_deriv(:,:)
		complex(dp),					intent(in)			::		V_ka(:,:,:)
		complex(dp),	allocatable,	intent(in)			::		Om_kab(:,:,:,:)
		complex(dp),	allocatable							::		kubo_curv(:,:,:)
		complex(dp)											::		om_ca(3)
		complex(dp)											::		tens(3,3)
		complex(dp),	allocatable							::		D_ab(:,:,:)
		integer												::		n, b, n_ef, n_wf, ef_idx
		!
		n_ef	=	size(fd_deriv,1)
		n_wf	=	size(fd_deriv,2)
		allocate(	D_ab(	3,3, n_ef))
		D_ab	=	0.0_dp
		!
		if(	.not.	allocated(Om_kab) )	then
			!	USE KUBO TO ESTIMATE CURV
			call get_kubo_curv(	en_k, V_ka, kubo_curv	)
			!
			!if(	.not. d_warning	)	then
			!	write(*,*)	"[get_gyro_D]: WARNING Curvature not allocated, will use velocities & energies to interpolate curvature!"
			!	d_warning = .True.
			!end if
		else
			!	USE GIVEN CURVATURE
			allocate(kubo_curv(3,3,n_wf))
			do n = 1, n_wf
				kubo_curv(:,:,n)	=	Om_kab(:,:,n,n)
			end do
		end if
		!
		!$OMP PARALLEL DO DEFAULT(none) 					&
		!$OMP PRIVATE(om_ca, tens, b, ef_idx) 				&
		!$OMP SHARED(n_wf, n_ef, V_ka, kubo_curv, fd_deriv)	&
		!$OMP REDUCTION(+: D_ab)
		do n =1 , n_wf
			tens	=	kubo_curv(:,:,n)
			call	convert_tens_to_vect(tens(:,:), om_ca(:)	)
			!
			tens = 0.0_dp
			do b = 1, 3
				tens(:,b)	=	tens(:,b)	+	V_ka(:,n,n) * om_ca(b)
			end do
			!
			do ef_idx	=	1 , n_ef
				D_ab(:,:,ef_idx)	=	D_ab(:,:,ef_idx)	-	tens(:,:)	* fd_deriv(ef_idx,n)
			end do
		end do
		!$OMP END PARALLEL DO
		!!
		!else
		!	!
		!	!$OMP PARALLEL DO DEFAULT(none) 					&
		!	!$OMP PRIVATE(om_ca, tens, b, ef_idx) 				&
		!	!$OMP SHARED(n_wf, n_ef, V_ka, Om_kab, fd_deriv)	&
		!	!$OMP REDUCTION(+: D_ab)
		!	do n =1 , n_wf
		!		call	convert_tens_to_vect(Om_kab(:,:,n,n), om_ca(:)	)
		!		!
		!		tens = 0.0_dp
		!		do b = 1, 3
		!			tens(:,b)	=	tens(:,b)	+	V_ka(:,n,n) * om_ca(b)
		!		end do
		!		!
		!		do ef_idx	=	1 , n_ef
		!			D_ab(:,:,ef_idx)	=	D_ab(:,:,ef_idx)	-	tens(:,:)	* fd_deriv(ef_idx,n)
		!		end do
		!	end do
		!	!$OMP END PARALLEL DO
		!	!
		!end if
		!
		return
	end function

	function get_gyro_Dw(en_k, V_ka, A_ka,hw_lst, fd_deriv)	result(Dw_ab)
		!
		!	see eq.(12) of PRB 97 035158 (2018)
		!
		complex(dp),	allocatable,	intent(in)	::	V_ka(:,:,:), A_ka(:,:,:)
		real(dp),						intent(in)	::	en_k(:), hw_lst(:), fd_deriv(:,:)
		complex(dp),	allocatable					::	Dw_ab(:,:,:,:), tens(:,:,:)
		real(dp),		allocatable					::	Om_hw(:,:,:)
		integer										::	n_wf, n_hw, n_ef, n, hw, b, ef_idx
		!
		!
		n_wf	=	size(en_k,		1)
		n_hw	=	size(hw_lst,	1)
		n_ef	=	size(fd_deriv,	1)
		!
		allocate(	Om_hw(		  3,	n_hw,			n_wf	))
		allocate(	tens(		3,3,	n_hw					))
		allocate(	Dw_ab(		3,3,	n_hw,	n_ef			))
		!
		Dw_ab	=	0.0_dp
		!
		if(	allocated(A_ka)) then
			!	PRECALC CURVATURE( FREQUENCY W)
			call get_curvTilde_hw(	en_k, A_ka, hw_lst, Om_hw)
			!
			!	LOOP BANDS
			do n =1 , n_wf
				!	ITERATE REAL SPACE DIRECTIONS
				tens 	=	0.0_dp
				do hw = 1, n_hw
					do b = 1, 3
						tens(:,b,hw)	=	tens(:,b,hw)	+	V_ka(:,n,n) * Om_hw(b,hw,n)
					end do
				end do
				!
				!	ITERATE FERMI LEVEL
				do ef_idx = 1, n_ef
					Dw_ab(:,:,:,ef_idx)	=	Dw_ab(:,:,:,ef_idx)	-	tens(:,:,:)	*	 fd_deriv(ef_idx, n)
				end do
			end do
			!
		end if
		!
		return
	end function

	function get_gyro_C(V_ka,  fd_deriv) result(C_ab)
		real(dp),		intent(in)			::		fd_deriv(:,:)
		complex(dp),	intent(in)			::		V_ka(:,:,:)
		complex(dp),	allocatable			::		C_ab(:,:,:)
		complex(dp)							::		tens(3,3)

		integer								::		n, b, n_ef, n_wf, ef_idx
		!
		n_ef	=	size(fd_deriv,1)
		n_wf	=	size(fd_deriv,2)
		allocate(	C_ab(	3,3,	n_ef	))
		C_ab	=	0.0_dp
		!
		!$OMP PARALLEL DO DEFAULT(none)		 	&
		!$OMP PRIVATE(b, tens, ef_idx) 			&
		!$OMP SHARED(n_wf, n_ef, V_ka, fd_deriv)	&
		!$OMP REDUCTION(+: C_ab)
		do n = 1, n_wf
			!
			!
			tens = 0.0_dp
			do b = 1, 3
				tens(:,b)	=	tens(:,b)	+	V_ka(:,n,n) * V_ka(b,n,n)
			end do
			!
			do ef_idx = 1, n_ef
				C_ab(:,:,ef_idx)	=	C_ab(:,:,ef_idx)	+	tens(:,:)	* fd_deriv(ef_idx, n)
			end do
			!
		end do
		!$OMP END PARALLEL DO
		!
		return
	end function

!	private:

	subroutine get_curvTilde_hw(en_k, A_ka, hw_lst, Om_tilde)
		!
		!	see eq.(C20) of PRB 97 035158 (2018)
		!
		real(dp),		intent(in)				::	en_k(:), hw_lst(:)
		complex(dp),	intent(in)				::	A_ka(:,:,:)
		real(dp)								::	om_tilde(:,:,:)
		real(dp)								::	ww_kmn
		real(dp)								::	om_vect(3)
		integer									::	n, m, n_wf, hw, n_hw
		!
		n_wf	=	size(en_k,	1)
		n_hw	=	size(hw_lst,1)
		!
		do n = 1, n_wf
			do m = 1, n_wf
				if(	m==n )	cycle
				!
				ww_kmn		=	(	en_k( m) -	en_k( n)	)**2
				om_vect(:)	=	aimag(	crossP(	A_ka(:,n,m),	A_ka(:,m,n)	)	)
				!
				!
				om_vect = 	om_vect * ww_kmn
				do hw = 1, n_hw
					om_tilde(:,hw,n)	=	om_tilde(:, hw, n)	- 	om_vect(:)	 /	(	ww_kmn - hw_lst(hw)	)
				end do
			end do
		end do
		!
		return
	end subroutine

end module gyro
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~
!~


c
        subroutine fixcapaq(val ,aux ,mitot,mjtot,mktot,
     &                      valc,auxc,mic  ,mjc  ,mkc  ,
     &                      nvar,naux,levc)

      use amr_module
      implicit double precision (a-h,o-z)

c
c :::::::::::::::::::::::  FIXCAPAQ ::::::::::::::::::::::::::::::
c  new fine grid solution q was linearly interpolated. but want
c  to conserve kappa*q, not q. calculate the discrepancy
c  in kappa*q using this q, and modify q to account for it.
c ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

      dimension   val(nvar,mitot,mjtot,mktot), valc(nvar,mic,mjc,mkc)
      dimension   aux(naux,mitot,mjtot,mktot), auxc(naux,mic,mjc,mkc)

      dcapamax = 0.d0
      lratiox  = intratx(levc)
      lratioy  = intraty(levc)
      lratioz  = intratz(levc)

      do 10 kc = 2, mkc-1
      do 10 jc = 2, mjc-1
      do 10 ic = 2, mic-1

       do 15 ivar = 1, nvar

       capaqfine = 0.d0

       do 20 kco = 1, lratioz
         kfine = (kc-2)*lratioz + nghost + kco
         do 20 jco = 1, lratioy
           jfine = (jc-2)*lratioy + nghost + jco
           do 20 ico = 1, lratiox
             ifine = (ic-2)*lratiox + nghost + ico
             capaqfine = capaqfine + aux(mcapa,ifine,jfine,kfine)
     &                             * val(ivar,ifine,jfine,kfine)
20     continue

       dcapaq = auxc(mcapa,ic,jc,kc)*valc(ivar,ic,jc,kc)-
     &          capaqfine/(lratiox*lratioy*lratioz)
       dcapamax = dmax1(dcapamax,dabs(dcapaq))

       do 30 kco = 1, lratioz
         kfine = (kc-2)*lratioz + nghost + kco
         do 30 jco = 1, lratioy
           jfine = (jc-2)*lratioy + nghost + jco
           do 30 ico = 1, lratiox
             ifine = (ic-2)*lratiox + nghost + ico
             val(ivar,ifine,jfine,kfine)  = val(ivar,ifine,jfine,kfine)
     &                             + dcapaq/aux(mcapa,ifine,jfine,kfine)
30     continue

15     continue

10     continue

c      write(6,*)" max discrepancy ", dcapamax

       return
       end


!==========================================================================
elemental function gsw_latentheat_melting (sa, p)
!==========================================================================
!
! Calculates latent heat, or enthalpy, of melting.
!
! sa     : Absolute Salinity                               [g/kg]
! p      : sea pressure                                    [dbar]
!
! gsw_latentheat_melting : latent heat of melting          [kg/m^3]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_enthalpy_ice, gsw_t_freezing_exact
use gsw_mod_toolbox, only : gsw_chem_potential_water_t_exact
use gsw_mod_toolbox, only : gsw_t_deriv_chem_potential_water_t_exact

use gsw_mod_teos10_constants, only : gsw_sfac, gsw_t0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p

real (r8) :: gsw_latentheat_melting

real (r8) :: tf

tf = gsw_t_freezing_exact(sa,p,0.0_r8);

gsw_latentheat_melting = 1000.0_r8*(gsw_chem_potential_water_t_exact(sa,tf,p) &
           - (gsw_t0 + tf)*gsw_t_deriv_chem_potential_water_t_exact(sa,tf,p)) &
           - gsw_enthalpy_ice(tf,p);

return
end function

!--------------------------------------------------------------------------


SUBROUTINE calc_fugacity_1(p,Ads_spec)
!
! The subroutine calculates the vapour fugacity using the Peng-Robinson EOS.
! The equations for the pure components  are taken from Sandler "Chemical
! and Engineering Thermodynamics" (1989) page 148, 149, 182, 222, the
! equations for the mixture are taken from Prausnitz et al. "Molecular
! Thermodynamics of Fluid-Phase Equilibria" (1986).
! The fugacity is used to calculate the activity in the main program.
!
!
! fuga_coeff    	real    fugacity coefficient
! Sandler
! kappa         	real    equation 4.7-4
! alphaT        	real    equation 4.7-3
! agreek        	real    equation 4.7-1
! bgreek        	real    equation 4.7-2
! A, B          	real    equation 4.7-5
! alpha, beta, gamma   	real    table 4.4-3
! Prausnitz
! agreek_sys            real 	equation 10.3-14/16
! b_greek_sys		real   	equation 10.3-13/15 (c12 = 0, simple mixture
!				of nonpolar components)
! Conv_Crit     	real	convergence criteria for Newton Rhapson method
! Z0, Z1        	real    approximation of zero, z: compressibility factor
!
! R			real    universial gas constant
! p            input    integer pressure point
! ads_species  input    integer adsorbed species
!
 USE fuga_mod
 USE molecules_prop
 USE diverses
!
 IMPLICIT NONE
!
 REAL(kind = realkind)                        :: fuga_coeff
 REAL(kind = realkind)                        :: alpha, beta_f, gamma
 REAL(kind = realkind), DIMENSION(no_species) :: kappa, alphaT, agreek, bgreek
 REAL(kind = realkind)                        :: agreek_sys, bgreek_sys
 REAL(kind = realkind)                        :: A, B
 REAL(kind = realkind)                        :: Z0, Z1
 REAL(kind = realkind)                        :: sum_za
 INTEGER                       	              :: i,j, spec
 INTEGER                                      :: p, ads_spec
!
 REAL(kind = realkind), PARAMETER  :: R = 8.314
 REAL(kind = realkind), PARAMETER  :: Conv_Crit = 1e-5
!
 DO spec = 1, no_species
    kappa(spec) = 0.37464 + 1.54226*acc_factor(spec) - &
                  0.26992*acc_factor(spec)*acc_factor(spec)
    alphaT(spec) = (1 + kappa(spec) * (1 - sqrt(Temp/T_crit(spec))))**2
!
! calculate a (a_greek), b (b_greek) for pure components
!
    agreek(spec) = 0.45724 * (R * T_crit(spec))**2 / P_crit(spec) * alphaT(spec)
    bgreek(spec) = 0.0778 * R * T_crit(spec) / P_crit(spec)
 END DO
!
! calculate the system a and b factors
!
 agreek_sys = 0.
 bgreek_sys = 0.
 IF (no_species == 1) THEN
   agreek_sys = agreek(1)
   bgreek_sys = bgreek(1)
 ELSE
   DO i = 1, no_species
     DO j = 1, no_species
       agreek_sys = agreek_sys + &
                    y_gas(i)*y_gas(j)*SQRT(agreek(i)*agreek(j))*(1-k(i,j))
     END DO
       bgreek_sys = bgreek_sys + y_gas(i)*bgreek(i)
   END DO
 END IF
!
! calculate A and B
!
    A = agreek_sys * Press(p) / (R * Temp)**2
    B = bgreek_sys * Press(p) / R / Temp
!
! calculate alpha, beta, gamma
!
 alpha = B - 1
 beta_f = A - 3*B*B - 2*B
 gamma = -A*B + B*B + B*B*B

!
! Searching for zero using Newton-Rhapson
! Z**3 + alpha*Z**2 + beta_f*Z + gamma = 0
! Z: compressibility facor
!
 Z1 = 1.0
 DO
    Z0 = Z1
    Z1 = Z0 - (Z0**3 + alpha*Z0**2 + beta_f*Z0 + gamma) / (3*Z0**2 + 2*alpha*Z0 &
            +beta_f)
    IF (ABS(Z1 - Z0) < Conv_Crit)  EXIT
 END DO
!
! calculate the sum(aik*zi)
!
 sum_za = 0.0
 DO spec = 1, no_species
    sum_za = sum_za + y_gas(spec)*SQRT(agreek(ads_spec)*agreek(spec))*(1-K(ads_spec,spec))
 END DO
!
! calculate fugacity coefficient
!
 fuga_coeff = EXP(bgreek(ads_spec)/bgreek_sys*(Z1-1) - LOG(Z1 - B) - &
              agreek_sys/(2.*SQRT(2.0)*bgreek_sys*R*temp)* &
              (2*sum_za/agreek_sys-bgreek(ads_spec)/bgreek_sys) &
              * LOG( (Z1+(1+SQRT(2.0))*B)/(Z1+(1-SQRT(2.0))*B)))
!
 fugacity(ads_spec) = fuga_coeff *y_gas(ads_spec) * Press(p)
!
END SUBROUTINE calc_fugacity_1


SUBROUTINE conab(sgm,sge)

!-------------------------------------------------------------
!
!  Construct the A and B matrices that make the gamma matrix
!  A and B matrices specific for an ordinate (n) and cell (x,y)
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: sgm, sge
INTEGER :: k, l, ieq, ll, col, mltx, mlty, mltxx, mltyy

! at end will have:  ieq = ordsq + 2*order
! Initialize the amat and bmat values
amat = 0.0
bmat = 0.0

! Set ieq
ieq = 0

! Begin constructing the matrices by advancing through the equations
! From the AHOT-N equations
DO k = 0, lambda
   mltx = sgm**k
   mltxx = ((-1)**k)*mltx
   DO l = 0, lambda
      mlty = sge**l
      mltyy = ((-1)**l)*mlty
      ! Start with the 00 equation, then 01, 02, ...
      ieq = ieq + 1

      ! amat contribution from total interaction
      amat(ieq,ieq) = amat(ieq,ieq) + 1.0

      ! contribution from x-dir summation
      DO ll = MOD((k+1),2), (k-1), 2
         col = order*ll + l + 1
         amat(ieq,col) = amat(ieq,col) - sgm*(2.0*ll+1.0)/ex
      END DO

      ! Contribution from y-dir summation
      DO ll = MOD((l+1),2), (l-1), 2
         col = order*k + ll + 1
         amat(ieq,col) = amat(ieq,col) - sge*(2.0*ll+1.0)/ey
      END DO

      ! Contribution from outgoing y flux (amat) and incoming y flux (bmat)
      col = ordsq + 1 + k
      amat(ieq,col) = amat(ieq,col) + mlty/(2.0*ey)
      bmat(ieq,col) = bmat(ieq,col) + mltyy/(2.0*ey)

      ! Contribution from outgoing x flux (amat) and incoming x flux (bmat)
      col = ordsq + order + 1 + l
      amat(ieq,col) = amat(ieq,col) + mltx/(2.0*ex)
      bmat(ieq,col) = bmat(ieq,col) + mltxx/(2.0*ex)

      ! bmat contribution from scattering and fixed source
      bmat(ieq,ieq) = bmat(ieq,ieq) + 1.0

   ! Finished with the AHOT-N equations
   END DO
END DO

! Contributions from the WDD equations
! y-direction
DO k = 0, lambda
   ieq = ieq + 1
   ! Contributions to amat from even summations
   DO ll = 0, lambda, 2
      col = order*k + ll + 1
      amat(ieq,col) = amat(ieq,col) + (2.0*ll + 1.0)
   END DO
   ! Contributions to amat from odd summations
   DO ll = 1, lambda, 2
      col = order*k + ll + 1
      amat(ieq,col) = amat(ieq,col) + sge*beta*(2.0*ll+1.0)
   END DO
   ! Contribution from outgoing flux
   col = ordsq + 1 + k
   amat(ieq,col) = amat(ieq,col) - (1.0+beta)/2.0
   ! Contribution to bmat from incoming flux
   bmat(ieq,col) = bmat(ieq,col) + (1.0-beta)/2.0
! Done with y-direction
END DO
! x-direction
DO l = 0, lambda
   ieq = ieq + 1
   ! Contributions to amat from even summations
   DO ll = 0, lambda, 2
      col = order*ll + l + 1
      amat(ieq,col) = amat(ieq,col) + (2.0*ll + 1.0)
   END DO
   ! Contributions to amat from odd summations
   DO ll = 1, lambda, 2
      col = order*ll + l + 1
      amat(ieq,col) = amat(ieq,col) + sgm*alpha*(2.0*ll+1.0)
   END DO
   ! Contribution from outgoing flux
   col = ordsq + order + 1 + l
   amat(ieq,col) = amat(ieq,col) - (1.0+alpha)/2.0
   ! Contribution to bmat from incoming flux
   bmat(ieq,col) = bmat(ieq,col) + (1.0-alpha)/2.0
! Done with x-direction
END DO

RETURN
END SUBROUTINE conab


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine compute_rhs

c---------------------------------------------------------------------
c---------------------------------------------------------------------

       include 'header.h'

       integer i, j, k, m
       double precision aux, rho_inv, uijk, up1, um1, vijk, vp1, vm1,
     >                  wijk, wp1, wm1

!$omp parallel default(shared) private(i,j,k,m,rho_inv,aux,uijk,up1,um1,
!$omp&   vijk,vp1,vm1,wijk,wp1,wm1)
c---------------------------------------------------------------------
c      compute the reciprocal of density, and the kinetic energy,
c      and the speed of sound.
c---------------------------------------------------------------------

!$omp do schedule(static)
       do    k = 0, grid_points(3)-1
          do    j = 0, grid_points(2)-1
             do    i = 0, grid_points(1)-1
                rho_inv = 1.0d0/u(1,i,j,k)
                rho_i(i,j,k) = rho_inv
                us(i,j,k) = u(2,i,j,k) * rho_inv
                vs(i,j,k) = u(3,i,j,k) * rho_inv
                ws(i,j,k) = u(4,i,j,k) * rho_inv
                square(i,j,k)     = 0.5d0* (
     >                        u(2,i,j,k)*u(2,i,j,k) +
     >                        u(3,i,j,k)*u(3,i,j,k) +
     >                        u(4,i,j,k)*u(4,i,j,k) ) * rho_inv
                qs(i,j,k) = square(i,j,k) * rho_inv
c---------------------------------------------------------------------
c               (don't need speed and ainx until the lhs computation)
c---------------------------------------------------------------------
                aux = c1c2*rho_inv* (u(5,i,j,k) - square(i,j,k))
                speed(i,j,k) = dsqrt(aux)
             end do
          end do
       end do
!$omp end do nowait

c---------------------------------------------------------------------
c copy the exact forcing term to the right hand side;  because
c this forcing term is known, we can store it on the whole grid
c including the boundary
c---------------------------------------------------------------------

!$omp do schedule(static)
       do    k = 0, nz2+1
          do    j = 0, ny2+1
             do    i = 0, nx2+1
                do    m = 1, 5
                   rhs(m,i,j,k) = forcing(m,i,j,k)
                end do
             end do
          end do
       end do
!$omp end do

c---------------------------------------------------------------------
c      compute xi-direction fluxes
c---------------------------------------------------------------------
!$omp master
       if (timeron) call timer_start(t_rhsx)
!$omp end master
!$omp do schedule(static)
       do    k = 1, nz2
          do    j = 1, ny2
             do    i = 1, nx2
                uijk = us(i,j,k)
                up1  = us(i+1,j,k)
                um1  = us(i-1,j,k)

                rhs(1,i,j,k) = rhs(1,i,j,k) + dx1tx1 *
     >                    (u(1,i+1,j,k) - 2.0d0*u(1,i,j,k) +
     >                     u(1,i-1,j,k)) -
     >                    tx2 * (u(2,i+1,j,k) - u(2,i-1,j,k))

                rhs(2,i,j,k) = rhs(2,i,j,k) + dx2tx1 *
     >                    (u(2,i+1,j,k) - 2.0d0*u(2,i,j,k) +
     >                     u(2,i-1,j,k)) +
     >                    xxcon2*con43 * (up1 - 2.0d0*uijk + um1) -
     >                    tx2 * (u(2,i+1,j,k)*up1 -
     >                           u(2,i-1,j,k)*um1 +
     >                           (u(5,i+1,j,k)- square(i+1,j,k)-
     >                            u(5,i-1,j,k)+ square(i-1,j,k))*
     >                            c2)

                rhs(3,i,j,k) = rhs(3,i,j,k) + dx3tx1 *
     >                    (u(3,i+1,j,k) - 2.0d0*u(3,i,j,k) +
     >                     u(3,i-1,j,k)) +
     >                    xxcon2 * (vs(i+1,j,k) - 2.0d0*vs(i,j,k) +
     >                              vs(i-1,j,k)) -
     >                    tx2 * (u(3,i+1,j,k)*up1 -
     >                           u(3,i-1,j,k)*um1)

                rhs(4,i,j,k) = rhs(4,i,j,k) + dx4tx1 *
     >                    (u(4,i+1,j,k) - 2.0d0*u(4,i,j,k) +
     >                     u(4,i-1,j,k)) +
     >                    xxcon2 * (ws(i+1,j,k) - 2.0d0*ws(i,j,k) +
     >                              ws(i-1,j,k)) -
     >                    tx2 * (u(4,i+1,j,k)*up1 -
     >                           u(4,i-1,j,k)*um1)

                rhs(5,i,j,k) = rhs(5,i,j,k) + dx5tx1 *
     >                    (u(5,i+1,j,k) - 2.0d0*u(5,i,j,k) +
     >                     u(5,i-1,j,k)) +
     >                    xxcon3 * (qs(i+1,j,k) - 2.0d0*qs(i,j,k) +
     >                              qs(i-1,j,k)) +
     >                    xxcon4 * (up1*up1 -       2.0d0*uijk*uijk +
     >                              um1*um1) +
     >                    xxcon5 * (u(5,i+1,j,k)*rho_i(i+1,j,k) -
     >                              2.0d0*u(5,i,j,k)*rho_i(i,j,k) +
     >                              u(5,i-1,j,k)*rho_i(i-1,j,k)) -
     >                    tx2 * ( (c1*u(5,i+1,j,k) -
     >                             c2*square(i+1,j,k))*up1 -
     >                            (c1*u(5,i-1,j,k) -
     >                             c2*square(i-1,j,k))*um1 )
             end do
          end do

c---------------------------------------------------------------------
c      add fourth order xi-direction dissipation
c---------------------------------------------------------------------
          do    j = 1, ny2
             i = 1
             do    m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k)- dssp *
     >                    ( 5.0d0*u(m,i,j,k) - 4.0d0*u(m,i+1,j,k) +
     >                            u(m,i+2,j,k))
             end do

             i = 2
             do    m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    (-4.0d0*u(m,i-1,j,k) + 6.0d0*u(m,i,j,k) -
     >                      4.0d0*u(m,i+1,j,k) + u(m,i+2,j,k))
             end do
          end do

          do    j = 1, ny2
             do  i = 3, nx2-2
                do     m = 1, 5
                   rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    (  u(m,i-2,j,k) - 4.0d0*u(m,i-1,j,k) +
     >                     6.0*u(m,i,j,k) - 4.0d0*u(m,i+1,j,k) +
     >                         u(m,i+2,j,k) )
                end do
             end do
          end do

          do    j = 1, ny2
             i = nx2-1
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    ( u(m,i-2,j,k) - 4.0d0*u(m,i-1,j,k) +
     >                      6.0d0*u(m,i,j,k) - 4.0d0*u(m,i+1,j,k) )
             end do

             i = nx2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    ( u(m,i-2,j,k) - 4.d0*u(m,i-1,j,k) +
     >                      5.d0*u(m,i,j,k) )
             end do
          end do
       end do
!$omp end do nowait
!$omp master
       if (timeron) call timer_stop(t_rhsx)

c---------------------------------------------------------------------
c      compute eta-direction fluxes
c---------------------------------------------------------------------
       if (timeron) call timer_start(t_rhsy)
!$omp end master
!$omp do schedule(static)
       do     k = 1, nz2
          do     j = 1, ny2
             do     i = 1, nx2
                vijk = vs(i,j,k)
                vp1  = vs(i,j+1,k)
                vm1  = vs(i,j-1,k)
                rhs(1,i,j,k) = rhs(1,i,j,k) + dy1ty1 *
     >                   (u(1,i,j+1,k) - 2.0d0*u(1,i,j,k) +
     >                    u(1,i,j-1,k)) -
     >                   ty2 * (u(3,i,j+1,k) - u(3,i,j-1,k))
                rhs(2,i,j,k) = rhs(2,i,j,k) + dy2ty1 *
     >                   (u(2,i,j+1,k) - 2.0d0*u(2,i,j,k) +
     >                    u(2,i,j-1,k)) +
     >                   yycon2 * (us(i,j+1,k) - 2.0d0*us(i,j,k) +
     >                             us(i,j-1,k)) -
     >                   ty2 * (u(2,i,j+1,k)*vp1 -
     >                          u(2,i,j-1,k)*vm1)
                rhs(3,i,j,k) = rhs(3,i,j,k) + dy3ty1 *
     >                   (u(3,i,j+1,k) - 2.0d0*u(3,i,j,k) +
     >                    u(3,i,j-1,k)) +
     >                   yycon2*con43 * (vp1 - 2.0d0*vijk + vm1) -
     >                   ty2 * (u(3,i,j+1,k)*vp1 -
     >                          u(3,i,j-1,k)*vm1 +
     >                          (u(5,i,j+1,k) - square(i,j+1,k) -
     >                           u(5,i,j-1,k) + square(i,j-1,k))
     >                          *c2)
                rhs(4,i,j,k) = rhs(4,i,j,k) + dy4ty1 *
     >                   (u(4,i,j+1,k) - 2.0d0*u(4,i,j,k) +
     >                    u(4,i,j-1,k)) +
     >                   yycon2 * (ws(i,j+1,k) - 2.0d0*ws(i,j,k) +
     >                             ws(i,j-1,k)) -
     >                   ty2 * (u(4,i,j+1,k)*vp1 -
     >                          u(4,i,j-1,k)*vm1)
                rhs(5,i,j,k) = rhs(5,i,j,k) + dy5ty1 *
     >                   (u(5,i,j+1,k) - 2.0d0*u(5,i,j,k) +
     >                    u(5,i,j-1,k)) +
     >                   yycon3 * (qs(i,j+1,k) - 2.0d0*qs(i,j,k) +
     >                             qs(i,j-1,k)) +
     >                   yycon4 * (vp1*vp1       - 2.0d0*vijk*vijk +
     >                             vm1*vm1) +
     >                   yycon5 * (u(5,i,j+1,k)*rho_i(i,j+1,k) -
     >                             2.0d0*u(5,i,j,k)*rho_i(i,j,k) +
     >                             u(5,i,j-1,k)*rho_i(i,j-1,k)) -
     >                   ty2 * ((c1*u(5,i,j+1,k) -
     >                           c2*square(i,j+1,k)) * vp1 -
     >                          (c1*u(5,i,j-1,k) -
     >                           c2*square(i,j-1,k)) * vm1)
             end do
          end do

c---------------------------------------------------------------------
c      add fourth order eta-direction dissipation
c---------------------------------------------------------------------

          j = 1
          do     i = 1, nx2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k)- dssp *
     >                    ( 5.0d0*u(m,i,j,k) - 4.0d0*u(m,i,j+1,k) +
     >                            u(m,i,j+2,k))
             end do
          end do

          j = 2
          do     i = 1, nx2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    (-4.0d0*u(m,i,j-1,k) + 6.0d0*u(m,i,j,k) -
     >                      4.0d0*u(m,i,j+1,k) + u(m,i,j+2,k))
             end do
          end do

          do    j = 3, ny2-2
             do  i = 1,nx2
                do     m = 1, 5
                   rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    (  u(m,i,j-2,k) - 4.0d0*u(m,i,j-1,k) +
     >                     6.0*u(m,i,j,k) - 4.0d0*u(m,i,j+1,k) +
     >                         u(m,i,j+2,k) )
                end do
             end do
          end do

          j = ny2-1
          do     i = 1, nx2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    ( u(m,i,j-2,k) - 4.0d0*u(m,i,j-1,k) +
     >                      6.0d0*u(m,i,j,k) - 4.0d0*u(m,i,j+1,k) )
             end do
          end do

          j = ny2
          do     i = 1, nx2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    ( u(m,i,j-2,k) - 4.d0*u(m,i,j-1,k) +
     >                      5.d0*u(m,i,j,k) )
             end do
          end do
       end do
!$omp end do
!$omp master
       if (timeron) call timer_stop(t_rhsy)

c---------------------------------------------------------------------
c      compute zeta-direction fluxes
c---------------------------------------------------------------------
       if (timeron) call timer_start(t_rhsz)
!$omp end master
!$omp do schedule(static)
       do    k = 1, grid_points(3)-2
          do     j = 1, grid_points(2)-2
             do     i = 1, grid_points(1)-2
                wijk = ws(i,j,k)
                wp1  = ws(i,j,k+1)
                wm1  = ws(i,j,k-1)

                rhs(1,i,j,k) = rhs(1,i,j,k) + dz1tz1 *
     >                   (u(1,i,j,k+1) - 2.0d0*u(1,i,j,k) +
     >                    u(1,i,j,k-1)) -
     >                   tz2 * (u(4,i,j,k+1) - u(4,i,j,k-1))
                rhs(2,i,j,k) = rhs(2,i,j,k) + dz2tz1 *
     >                   (u(2,i,j,k+1) - 2.0d0*u(2,i,j,k) +
     >                    u(2,i,j,k-1)) +
     >                   zzcon2 * (us(i,j,k+1) - 2.0d0*us(i,j,k) +
     >                             us(i,j,k-1)) -
     >                   tz2 * (u(2,i,j,k+1)*wp1 -
     >                          u(2,i,j,k-1)*wm1)
                rhs(3,i,j,k) = rhs(3,i,j,k) + dz3tz1 *
     >                   (u(3,i,j,k+1) - 2.0d0*u(3,i,j,k) +
     >                    u(3,i,j,k-1)) +
     >                   zzcon2 * (vs(i,j,k+1) - 2.0d0*vs(i,j,k) +
     >                             vs(i,j,k-1)) -
     >                   tz2 * (u(3,i,j,k+1)*wp1 -
     >                          u(3,i,j,k-1)*wm1)
                rhs(4,i,j,k) = rhs(4,i,j,k) + dz4tz1 *
     >                   (u(4,i,j,k+1) - 2.0d0*u(4,i,j,k) +
     >                    u(4,i,j,k-1)) +
     >                   zzcon2*con43 * (wp1 - 2.0d0*wijk + wm1) -
     >                   tz2 * (u(4,i,j,k+1)*wp1 -
     >                          u(4,i,j,k-1)*wm1 +
     >                          (u(5,i,j,k+1) - square(i,j,k+1) -
     >                           u(5,i,j,k-1) + square(i,j,k-1))
     >                          *c2)
                rhs(5,i,j,k) = rhs(5,i,j,k) + dz5tz1 *
     >                   (u(5,i,j,k+1) - 2.0d0*u(5,i,j,k) +
     >                    u(5,i,j,k-1)) +
     >                   zzcon3 * (qs(i,j,k+1) - 2.0d0*qs(i,j,k) +
     >                             qs(i,j,k-1)) +
     >                   zzcon4 * (wp1*wp1 - 2.0d0*wijk*wijk +
     >                             wm1*wm1) +
     >                   zzcon5 * (u(5,i,j,k+1)*rho_i(i,j,k+1) -
     >                             2.0d0*u(5,i,j,k)*rho_i(i,j,k) +
     >                             u(5,i,j,k-1)*rho_i(i,j,k-1)) -
     >                   tz2 * ( (c1*u(5,i,j,k+1) -
     >                            c2*square(i,j,k+1))*wp1 -
     >                           (c1*u(5,i,j,k-1) -
     >                            c2*square(i,j,k-1))*wm1)
             end do
          end do
       end do
!$omp end do

c---------------------------------------------------------------------
c      add fourth order zeta-direction dissipation
c---------------------------------------------------------------------

       k = 1
!$omp do schedule(static)
       do     j = 1, grid_points(2)-2
          do     i = 1, grid_points(1)-2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k)- dssp *
     >                    ( 5.0d0*u(m,i,j,k) - 4.0d0*u(m,i,j,k+1) +
     >                            u(m,i,j,k+2))
             end do
          end do
       end do
!$omp end do nowait

       k = 2
!$omp do schedule(static)
       do     j = 1, grid_points(2)-2
          do     i = 1, grid_points(1)-2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    (-4.0d0*u(m,i,j,k-1) + 6.0d0*u(m,i,j,k) -
     >                      4.0d0*u(m,i,j,k+1) + u(m,i,j,k+2))
             end do
          end do
       end do
!$omp end do nowait

!$omp do schedule(static)
       do     k = 3, grid_points(3)-4
          do     j = 1, grid_points(2)-2
             do     i = 1,grid_points(1)-2
                do     m = 1, 5
                   rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    (  u(m,i,j,k-2) - 4.0d0*u(m,i,j,k-1) +
     >                     6.0*u(m,i,j,k) - 4.0d0*u(m,i,j,k+1) +
     >                         u(m,i,j,k+2) )
                end do
             end do
          end do
       end do
!$omp end do nowait

       k = grid_points(3)-3
!$omp do schedule(static)
       do     j = 1, grid_points(2)-2
          do     i = 1, grid_points(1)-2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    ( u(m,i,j,k-2) - 4.0d0*u(m,i,j,k-1) +
     >                      6.0d0*u(m,i,j,k) - 4.0d0*u(m,i,j,k+1) )
             end do
          end do
       end do
!$omp end do nowait

       k = grid_points(3)-2
!$omp do schedule(static)
       do     j = 1, grid_points(2)-2
          do     i = 1, grid_points(1)-2
             do     m = 1, 5
                rhs(m,i,j,k) = rhs(m,i,j,k) - dssp *
     >                    ( u(m,i,j,k-2) - 4.d0*u(m,i,j,k-1) +
     >                      5.d0*u(m,i,j,k) )
             end do
          end do
       end do
!$omp end do
!$omp master
       if (timeron) call timer_stop(t_rhsz)
!$omp end master

!$omp do schedule(static)
       do    k = 1, nz2
          do    j = 1, ny2
             do    i = 1, nx2
                do    m = 1, 5
                   rhs(m,i,j,k) = rhs(m,i,j,k) * dt
                end do
             end do
          end do
       end do
!$omp end do nowait
!$omp end parallel

       return
       end


!##############################################################################
! PROGRAM creditriskmanagement
!
! ## Credit risk management with one bond
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program creditriskmanagement

    implicit none
    integer, parameter :: KK = 8           ! number of ratings
    integer, parameter :: JJ = 5           ! number of industries
    real*8, parameter  :: sig_RR = 0.25d0  ! volatility of recovery rate
    real*8, parameter  :: r_f = 0.03d0     ! riskfree rate

    real*8 :: RM_data(KK-1, KK), cs_data(KK-1), RR_data(JJ)
    real*8 :: pi_D, NE, mu_RR, LGD, cs, cr, pi_k(KK)
    real*8 :: EL_d, UL_d, EL_m, UL_m
    real*8 :: p_0, p_prime
    integer :: ij, ik, ik_p, it, TT

    ! define a bond type
    type :: bond_type
        character(len=1) :: industry
        character(len=3) :: rating
        real*8 :: couponrate
        integer :: maturity
        real*8 :: exposure
    end type

    ! declare the bond variable
    type(bond_type) :: bond

    ! initialize bond data
    call init_data

    ! set up a bond
    bond = bond_type('F', 'BBB', 5.00d0,  4, 1000000d0)

    ! retrieve the bond's properties
    cr    = bond%couponrate/100d0
    TT    = bond%maturity
    NE    = bond%exposure
    ij    = ij_code(bond%industry)
    ik    = ik_code(bond%rating)
    pi_D  = RM_data(ik, KK)
    pi_k  = RM_data(ik, :)
    cs    = cs_data(ik)
    mu_RR = RR_data(ij)

    ! calculate price under current rating
    p_0 = 0d0
    do it = 1, TT-1
        p_0 = p_0 + cr/(1d0 + r_f + cs)**it
    enddo
    p_0 = p_0 + (1d0 + cr)/(1d0 + r_f + cs)**TT

    ! define loss given default
    LGD = p_0 - mu_RR

    ! default mode
    EL_d = NE*pi_D*LGD
    UL_d = NE*sqrt(pi_D*sig_RR**2 + LGD**2*pi_D*(1d0-pi_D))

    ! migration mode
    EL_m = 0d0
    UL_m = 0d0

    ! iterate over all potential credit events (except default)
    do ik_p = 1, KK-1

        cs = cs_data(ik_p)

        ! calculate price change if credit rating changes
        p_prime = 0d0
        do it = 1, TT-1
            p_prime = p_prime + cr/(1d0 + r_f + cs)**it
        enddo
        p_prime = p_prime + (1d0 + cr)/(1d0 + r_f + cs)**TT

        EL_m = EL_m + pi_k(ik_p)*(p_0 - p_prime)
        UL_m = UL_m + pi_k(ik_p)*(p_0 - p_prime)**2
    enddo

    ! add default state
    EL_m = EL_m + pi_D*LGD
    UL_m = UL_m + pi_D*(sig_RR**2 + LGD**2)

    ! determine EL and UL in migration model
    EL_m = NE*EL_m
    UL_m = NE*sqrt(UL_m - (EL_m/NE)**2)

    ! print results
    write(*,'(a)')'RISK ANALYSIS OF CORPORATE BOND'
    write(*, *)
    write(*,'(a)')'I  R        cr   T         p_0        EL_D        UL_D        EL_M        UL_M'
    write(*,'(a1,a5,f8.2,i4,f12.6,4f12.2)')bond%industry, bond%rating, &
                        cr*100d0, TT, p_0, EL_d, UL_d, EL_m, UL_m
    write(*,'(32x,4(f10.2,a))')EL_d/NE*10000d0, 'bp', UL_d/NE*10000d0, 'bp', &
                               EL_m/NE*10000d0, 'bp', UL_m/NE*10000d0, 'bp'

contains

    ! initialize the probability parameters
    subroutine init_data()

        implicit none

        RM_data(1, :) = (/ 90.24d0,  8.99d0,  0.56d0,  0.05d0,  0.08d0,  0.03d0,  0.05d0,  0.00d0 /)
        RM_data(2, :) = (/  0.58d0, 90.03d0,  8.65d0,  0.56d0,  0.06d0,  0.08d0,  0.02d0,  0.02d0 /)
        RM_data(3, :) = (/  0.04d0,  2.00d0, 91.58d0,  5.71d0,  0.40d0,  0.17d0,  0.02d0,  0.08d0 /)
        RM_data(4, :) = (/  0.01d0,  0.13d0,  3.89d0, 90.69d0,  4.18d0,  0.68d0,  0.16d0,  0.26d0 /)
        RM_data(5, :) = (/  0.02d0,  0.04d0,  0.18d0,  5.81d0, 84.15d0,  7.97d0,  0.83d0,  1.00d0 /)
        RM_data(6, :) = (/  0.00d0,  0.05d0,  0.15d0,  0.25d0,  6.31d0, 83.16d0,  5.01d0,  5.07d0 /)
        RM_data(7, :) = (/  0.00d0,  0.00d0,  0.20d0,  0.30d0,  0.91d0, 15.96d0, 51.31d0, 31.32d0 /)
        RM_data = RM_data/100d0

        CS_data = (/0.00d0, 0.05d0, 1.00d0, 2.00d0, 5.00d0, 10.00d0, 20.00d0/)/100d0

        RR_data = (/0.437d0, 0.246d0, 0.575d0, 0.327d0, 0.493d0/)

    end subroutine init_data

    ! return rating code
    function ik_code(rating)

        implicit none
        character(len=3), intent(in) :: rating
        integer :: ik_code

        select case (rating)
            case('AAA')
                ik_code = 1
            case('AA')
                ik_code = 2
            case('A')
                ik_code = 3
            case('BBB')
                ik_code = 4
            case('BB')
                ik_code = 5
            case('B')
                ik_code = 6
            case('CCC')
                ik_code = 7
            case default
                stop 'Credit rating does not exists'
        end select

    end function

    ! return industry code
    function ij_code(industry)

        implicit none
        character(len=1), intent(in) :: industry
        integer :: ij_code

        select case (industry)
            case('M')
                ij_code = 1
            case('F')
                ij_code = 2
            case('U')
                ij_code = 3
            case('T')
                ij_code = 4
            case('S')
                ij_code = 5
            case default
                stop 'Industry does not exists'
        end select

    end function

end program