      PROGRAM range
!
! This program finds the range of a charged partcile in a plasma, where the
! charged particle is created with threshold energy Ep.
!
! The subroutine rk4(y,t,dt,nit) advances y at time t by nit iterations, each
! of which has a constant time-step dt.
!
! nts = number of time steps
! nit = number of iterations per time step
!
      USE allocatablevars
      USE bpsvars
      USE physvars
      USE mathvars
        IMPLICIT NONE
        INTEGER NTSMAX
        PARAMETER (NTSMAX=5000)

        REAL    :: y, v, t, dt, tmax, p
        REAL    :: xt(0:NTSMAX), vt(0:NTSMAX), tt(0:NTSMAX)
        REAL    :: dedx_tot,  dedx_i,  dedx_e
        REAL    :: dedxc_tot, dedxc_i, dedxc_e
        REAL    :: dedxq_tot, dedxq_i, dedxq_e
        INTEGER :: j, nts, nit

        REAL    :: te, ti, ne, ep, mp, zp
        REAL    :: de, epp
        INTEGER :: nni, nn
!
! Range parameters
!
        tmax=1.0E-11 ! [s]
        nts=100
        nit=10
        nn =300
        dt=tmax/(nts*nit)
        te=3.        ! [keV] Electron temperature
        ti=3.        ! [keV] Ion temperature
        ne=1.E25     ! [cm^-3] Electron number density
        ep=3540.     ! [keV] Projectile energy
        mp=4*MPKEV   ! [keV] Projectile mass
        zp=2.        ! [e] Projectile charge

        ! ! DT equimolar
        ! OPEN(1, FILE='range_DT.out')
        ! OPEN(2, FILE='dedx_DT.out')
        ! CALL define_plasma_DT(te,ti,ne,nni)

        ! ! DT doped with H, doping parameter p
        ! OPEN(1, FILE='range_Hp0.out')
        ! OPEN(2, FILE='dedx_Hp0.out')
        ! p = 0.
        ! CALL define_plasma_DTH(p, te,ti,ne,nni)

        ! ! DT doped with H, doping parameter p
        ! OPEN(1, FILE='range_Hp1.out')
        ! OPEN(2, FILE='dedx_Hp1.out')
        ! p = 1.
        ! CALL define_plasma_DTH(p, te,ti,ne,nni)

        ! ! DT doped with H, doping parameter p
        ! OPEN(1, FILE='range_Hp05.out')
        ! OPEN(2, FILE='dedx_Hp05.out')
        ! p = 0.5
        ! CALL define_plasma_DTH(p, te,ti,ne,nni)

        ! DT doped with H, doping parameter p
        OPEN(1, FILE='range_Hp01.out')
        OPEN(2, FILE='dedx_Hp01.out')
        p = 0.1
        CALL define_plasma_DTH(p, te,ti,ne,nni)

        CALL write_header(ep,mp,zp,te,ti,ne,nni,betab,zb,mb,nb)
!
! stopping power
!
        de=ep/nn
        epp=0
        WRITE(2,'(A, 4X,A, 3X,A10, 7X,A19, A9, 13X,A9 )') &
             '#', 'j', 'E_p [keV]', 'dedx_tot [MeV/mu-m]', 'dedx_i', 'dedx_e'
        DO j=0,nn
           epp=j*de
           IF (epp .EQ. 0) epp=1.E-5
           CALL dedx_bps(nni, epp, zp, mp, betab, zb, mb, nb,   &
             dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i,      &
             dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]
           WRITE (6,'(I6,E17.8,6E22.13)') j, epp, dedx_tot, dedx_i, dedx_e
           WRITE (2,'(I6,E17.8,6E22.13)') j, epp, dedx_tot, dedx_i, dedx_e
        END DO
        CLOSE (2)

! range
!
! initial conditions
!
        t=0                ! [s]
        y=0.               ! [cm]
        v=CC*SQRT(2*ep/mp) ! [cm/s]
        tt(0)=t
        xt(0)=y
        vt(0)=v
!
! evolution
!
        j=0
        ep=0.5*mp*(vt(j)/CC)**2
        WRITE(1,'(A, 4X,A, X,A6, 5X,A15, 15X,A11, 5X,A15, 13X,A19, 3X,A6, 16X,A6 )') '#', 'j', 'tt [s]', &
             'xt [cm]','vt [cm/s]','E_p [keV]','dedx_tot [MeV/mu-m]','dedx_i','dedx_e'
        Call dedx_bps(nni, ep, zp, mp, betab, zb, mb, nb,   &
            dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, &
            dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]

        WRITE(6,'(I6,E17.8,6E22.13)') j, tt(j), xt(j), vt(j), ep, dedx_tot, dedx_i, dedx_e
        WRITE(1,'(I6,E17.8,6E22.13)') j, tt(j), xt(j), vt(j), ep, dedx_tot, dedx_i, dedx_e
        DO j=1,nts
           CALL rk4(y,v,t,dt,nit,nni,zp,mp,dedx_tot,dedx_i,dedx_e)
           tt(j)=t ! [s]
           xt(j)=y ! [cm]
           vt(j)=v ! [cms/s]
           ep   =0.5*mp*(vt(j)/CC)**2 ! [keV]
           WRITE (6,'(I6,E17.8,6E22.13)') j, tt(j), xt(j), vt(j), ep, dedx_tot, dedx_i, dedx_e
           WRITE (1,'(I6,E17.8,6E22.13)') j, tt(j), xt(j), vt(j), ep, dedx_tot, dedx_i, dedx_e
        END DO

        CLOSE (1)
        END PROGRAM range

!
! SUBROUTINE rk4:
! Given the equation of motion
!
!   y'' = f(y,v,t)  ,
!
! this subroutine advances (y,v) at time t by nit iterations of
! length dt. The variable (y,v) and the time t are returned with
! their updated values.
!
      SUBROUTINE rk4(x, v, t, dt, nit, nni, zp, mp, dedx_tot, dedx_i, dedx_e)
      USE allocatablevars ! betab(1:nni+1), zb(1:nni+1), mb(1:nni+1), nb(1:nni+1)
      USE physvars
      IMPLICIT NONE
      REAL,    INTENT(INOUT) :: x, v, t
      REAL,    INTENT(INOUT) :: dt
      INTEGER, INTENT(IN)    :: nit
      INTEGER, INTENT(IN)    :: nni
      REAL,    INTENT(IN)    :: zp, mp
      REAL,    INTENT(OUT)   :: dedx_tot, dedx_i, dedx_e ! [MeV/micron]
      REAL    :: xx, vv, th, f
      REAL    :: xk1, xk2, xk3, xk4
      REAL    :: vk1, vk2, vk3, vk4
      REAL    :: dedxc_tot, dedxc_i, dedxc_e, dedxq_tot, dedxq_i, dedxq_e
      REAL    :: ep
      INTEGER :: it
      REAL, PARAMETER :: d6=0.1666666666666666666

      dedx_tot=0
      dedx_i  =0
      dedx_e  =0
      th=t+0.5*dt
      DO it=1,nit
!
! first intermediate step
!
         CALL force(v,f,nni,zp,mp)
         xk1=dt*v
         vk1=dt*f
         xx =x+0.5*xk1
         vv =v+0.5*vk1
!
! second intermediate step
!
         CALL force(vv,f,nni,zp,mp)
         xk2=dt*vv
         vk2=dt*f
         xx =x+0.5*xk2
         vv =v+0.5*vk2
!
! third intermediate step
!
         CALL force(vv,f,nni,zp,mp)
         xk3=dt*vv
         vk3=dt*f
         xx =x+xk3
         vv =v+vk3
!
! fourth intermediate step
!
         t=t+dt
         CALL force(v,f,nni,zp,mp)
         xk4=dt*v
         vk4=dt*f
!
         x = x + d6*(xk1 + 2*xk2 + 2*xk3 + xk4)
         v = v + d6*(vk1 + 2*vk2 + 2*vk3 + vk4)
      END DO
      ep = 0.5*mp*(v/CC)**2 ! [keV] projectile energy
      CALL dedx_bps(nni, ep, zp, mp, betab, zb, mb, nb,   &
        dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i,     &
        dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]
      END SUBROUTINE rk4
!
! SUBROUTINE force:
! Returns the force f(x,v,t,) for x''=f(x,v,t)
!
      SUBROUTINE force(v, f, nni, zp, mp)
      USE allocatablevars ! betab(1:nni+1), zb(1:nni+1), mb(1:nni+1), nb(1:nni+1)
      USE physvars
      IMPLICIT NONE
      REAL,    INTENT(IN) :: v
      REAL,    INTENT(OUT):: f
      INTEGER, INTENT(IN) :: nni
      REAL,    INTENT(IN) :: zp, mp
      REAL    :: ep
      REAL    :: dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, dedxc_e
      REAL    :: dedxq_tot, dedxq_i, dedxq_e
      REAL    :: KEV_TO_ERG=1.6022E-9
      REAL    :: f1, m1

      ep = 0.5*mp*(v/CC)**2  ! [keV] projectile energy
      CALL dedx_bps(nni, ep, zp, mp, betab, zb, mb, nb,   &
            dedx_tot, dedx_i, dedx_e, dedxc_tot, dedxc_i, &
            dedxc_e, dedxq_tot, dedxq_i, dedxq_e) ! [MeV/micron]

      f   = -dedx_tot             ! [MeV/mircon] is a force]
      f   = f * 1.E7              ! [keV/cm]
      f1  = f * KEV_TO_ERG        ! [erg]
      m1  = mp * KEV_TO_ERG / CC2 ! [g]
      f   = f1 / m1               ! [dyne]
      END SUBROUTINE force

    SUBROUTINE write_header(ep, mp, zp, te, ti, ne, nni, betab, zb, mb, nb)
    USE physvars
      IMPLICIT NONE
      REAL,                        INTENT(IN) :: ep     ! [keV]
      REAL,                        INTENT(IN) :: mp     ! [keV]
      REAL,                        INTENT(IN) :: zp     ! [e]
      REAL,                        INTENT(IN) :: te     ! [keV]
      REAL,                        INTENT(IN) :: ti     ! [keV]
      REAL,                        INTENT(IN) :: ne     ! [cm^-3]
      INTEGER,                     INTENT(IN) :: nni    ! number of ion species
      REAL,    DIMENSION(1:nni+1), INTENT(IN) :: betab  ! [1/keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN) :: zb     ! [e]
      REAL,    DIMENSION(1:nni+1), INTENT(IN) :: mb     ! [keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN) :: nb     ! [cm^-3]

      REAL  :: etae, ge, gi, ze
      REAL,    DIMENSION(1:nni+1) :: gb

      REAL  :: vp
      REAL,    DIMENSION(1:nni+1) :: ab, etab
!
! write header
!
      WRITE(6,'(A)') '#'
      WRITE(6,'(A, 3X,A21)') '#','Projectile Parameters'
      WRITE(6,'(A, 4X,A13, X,D12.4)') '#','charge      :', zp
      WRITE(6,'(A, 4X,A13, X,D12.4)') '#','mass   [amu]:', mp/AMUKEV
      WRITE(6,'(A, 4X,A13, X,D12.4)') '#','mass   [keV]:', mp
      WRITE(6,'(A, 4X,A13, X,D12.4)') '#','energy [keV]:', ep
      WRITE(6,'(A)') '#'
      WRITE(6,'(A, 3X,A17)') '#','Plasma Parameters'
      WRITE(6,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
      WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
      WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
      WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
      WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb

      WRITE(1,'(A)') '#'
      WRITE(1,'(A)') '#'
      WRITE(1,'(A, 3X,A17)') '#','Plasma Parameters'
      WRITE(1,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
      WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
      WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
      WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
      WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb
      WRITE(1,'(A)') '#'
      WRITE(1,'(A)') '#'
      WRITE(1,'(A, 3X,A21)') '#','Projectile Parameters'
      WRITE(1,'(A, 4X,A13, X,D12.4)') '#','charge      :', zp
      WRITE(1,'(A, 4X,A13, X,D12.4)') '#','mass   [amu]:', mp/AMUKEV
      WRITE(1,'(A, 4X,A13, X,D12.4)') '#','mass   [keV]:', mp
      WRITE(1,'(A, 4X,A13, X,D12.4)') '#','energy [keV]:', ep

      WRITE(2,'(A)') '#'
      WRITE(2,'(A)') '#'
      WRITE(2,'(A, 3X,A17)') '#','Plasma Parameters'
      WRITE(2,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
      WRITE(2,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
      WRITE(2,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
      WRITE(2,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
      WRITE(2,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb
      WRITE(2,'(A)') '#'
      WRITE(2,'(A)') '#'
      WRITE(2,'(A, 3X,A21)') '#','Projectile Parameters'
      WRITE(2,'(A, 4X,A13, X,D12.4)') '#','charge      :', zp
      WRITE(2,'(A, 4X,A13, X,D12.4)') '#','mass   [amu]:', mp/AMUKEV
      WRITE(2,'(A, 4X,A13, X,D12.4)') '#','mass   [keV]:', mp
      WRITE(2,'(A, 4X,A13, X,D12.4)') '#','energy [keV]:', ep
!
! Print plasma parameters
!
      CALL param(nni, betab, nb, gb, ge, gi, etae, ze)
      WRITE(6,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
        '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
      WRITE(6,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5
      WRITE(1,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
        '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
      WRITE(1,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5
      WRITE(2,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
        '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
      WRITE(2,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5

      vp  = CC*SQRT(2*ep/mp)       ! [cm/s]
      ab  =0.5*betab*mb*vp*vp/CC2  ! [dimensionless] (1/2) betab(ib)*mb(ib)*vp2/CC2
      etab=ABS(zp*zb)*2.1870E8/vp  ! [dimensionless]

      WRITE(6,'(A7, 4E12.4)') '# ab  =', ab
      WRITE(6,'(A7, 4E12.4)') '# etab=', etab
      WRITE(1,'(A7, 4E12.4)') '# ab  =', ab
      WRITE(1,'(A7, 4E12.4)') '# etab=', etab
      WRITE(2,'(A7, 4E12.4)') '# ab  =', ab
      WRITE(2,'(A7, 4E12.4)') '# etab=', etab

    END SUBROUTINE write_header

!
! SUBROUTINE define_plasma:
! Returns the plasma species arrays: betab, mb, nb, zb
! Allocates other plasma arrays
!
    SUBROUTINE define_plasma_DT(te, ti, ne, nni)

    USE allocatablevars
    USE physvars
      IMPLICIT NONE
      REAL                                :: te     ! [keV]
      REAL                                :: ti     ! [keV]
      REAL                                :: ne     ! [cm^-3]
      INTEGER                             :: nni    ! number of ion species
!     allocatablevars
!     REAL,    DIMENSION(:), ALLOCATABLE  :: betab  ! [1/keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: mb     ! [keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: nb     ! [cm^-3]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: zb     ! [e]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: gb, etab, mpb, mbpb

      nni=2  ! number of ion species

      ALLOCATE(betab(1:nni+1),zb(1:nni+1),mb(nni+1),nb(1:nni+1))   ! allocatablevars
      ALLOCATE(gb(1:nni+1),etab(1:nni+1),mpb(nni+1),mbpb(1:nni+1)) ! allocatablevars

      zb(1)=-1.    ! Species charges
      zb(2)=+1.    !
      zb(3)=+1.    !
      mb(1)=MEKEV  ! Species masses [keV]
      mb(2)=2*MPKEV!
      mb(3)=3*MPKEV!
!
! Construct density and temperature arrays
!
      nb(1)=1.                          ! ONLY FOR EQUIMOLAR DT
      nb(2:nni+1)=1./(zb(2:nni+1)*nni)  ! charge neutrality
      nb=nb*ne                          ! number density array [cm^-3]
      betab(1)=1./te                    ! inverse temp array   [keV^-1]
      betab(2:nni+1)=1./ti              !
    END SUBROUTINE define_plasma_DT
!
! SUBROUTINE define_plasma:
! Returns the plasma species arrays: betab, mb, nb, zb
! Allocates other plasma arrays
!
    SUBROUTINE define_plasma_H(te, ti, ne, nni)

    USE allocatablevars
    USE physvars
      IMPLICIT NONE
      REAL                                :: te     ! [keV]
      REAL                                :: ti     ! [keV]
      REAL                                :: ne     ! [cm^-3]
      INTEGER                             :: nni    ! number of ion species
!     allocatablevars
!     REAL,    DIMENSION(:), ALLOCATABLE  :: betab  ! [1/keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: mb     ! [keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: nb     ! [cm^-3]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: zb     ! [e]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: gb, etab, mpb, mbpb

      nni=1  ! number of ion species

      ALLOCATE(betab(1:nni+1),zb(1:nni+1),mb(nni+1),nb(1:nni+1))   ! allocatablevars
      ALLOCATE(gb(1:nni+1),etab(1:nni+1),mpb(nni+1),mbpb(1:nni+1)) ! allocatablevars

      zb(1)=-1.    ! Species charges
      zb(2)=+1.    !
      mb(1)=MEKEV  ! Species masses [keV]
      mb(2)=MPKEV!
!
!no-doped plasma: n = nD = nT
!doped plasma: np = npD = npT, nH = p np
!same plasma density => np = n 5 / ( 5 + p )
!
! Construct density and temperature arrays
!
      nb(1)=1.                          ! ONLY FOR EQUIMOLAR DT
      nb(2:nni+1)=1./(zb(2:nni+1)*nni)  ! charge neutrality
      nb=nb*ne                          ! number density array [cm^-3]
      betab(1)=1./te                    ! inverse temp array   [keV^-1]
      betab(2:nni+1)=1./ti              !
    END SUBROUTINE define_plasma_H

    SUBROUTINE define_plasma_DTH(p, te, ti, ne, nni)

    USE allocatablevars
    USE physvars
      IMPLICIT NONE
      REAL                                :: p      ! doping parameter
      REAL                                :: te     ! [keV]
      REAL                                :: ti     ! [keV]
      REAL                                :: ne     ! [cm^-3]
      INTEGER                             :: nni    ! number of ion species
!     allocatablevars
!     REAL,    DIMENSION(:), ALLOCATABLE  :: betab  ! [1/keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: mb     ! [keV]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: nb     ! [cm^-3]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: zb     ! [e]
!     REAL,    DIMENSION(:), ALLOCATABLE  :: gb, etab, mpb, mbpb

      WRITE(6,'(A, 4X,A3, E22.13 )')  '#', "p=", p
      WRITE(1,'(A, 4X,A3, E22.13 )')  '#', "p=", p
      WRITE(2,'(A, 4X,A3, E22.13 )')  '#', "p=", p

      nni = 3  ! D, T, H

      ALLOCATE(betab(1:nni+1),zb(1:nni+1),mb(nni+1),nb(1:nni+1))   ! allocatablevars
      ALLOCATE(gb(1:nni+1),etab(1:nni+1),mpb(nni+1),mbpb(1:nni+1)) ! allocatablevars

      zb(1) = -1.    ! e
      zb(2) = +1.    ! D
      zb(3) = +1.    ! T
      zb(4) = +1.    ! H
      mb(1) = MEKEV  ! e
      mb(2) = 2*MPKEV! D
      mb(3) = 3*MPKEV! T
      mb(4) = MPKEV  ! P
!
! Construct density and temperature arrays
!
      nb(1) = (5. * (2. + p)) / (2 * (5 + p)) ! ne
      nb(2) = nb(1) / (2. + p)                ! nD
      nb(3) = nb(2)                           ! nT
      nb(4) = p * nb(1)                       ! nH
      nb = nb * ne                            ! number density array [cm^-3]
      betab(1) = 1./te                        ! inverse temp array   [keV^-1]
      betab(2:nni+1) = 1./ti                  !
    END SUBROUTINE define_plasma_DTH


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYSPHE
C...Performs sphericity tensor analysis to give sphericity,
C...aplanarity and the related event axes.

      SUBROUTINE PYSPHE(SPH,APL)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYCHGE,PYCOMP

C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
      include 'inc/pyjets'
      include 'inc/pydat1'
      include 'inc/pydat2'

C...Local arrays.
      DIMENSION SM(3,3),SV(3,3)

C...Calculate matrix to be diagonalized.
      NP=0
      DO 110 J1=1,3
        DO 100 J2=J1,3
          SM(J1,J2)=0D0
  100   CONTINUE
  110 CONTINUE
      PS=0D0
      DO 140 I=1,N
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
        IF(MSTU(41).GE.2) THEN
          KC=PYCOMP(K(I,2))
          IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
     &    KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &    K(I,2).EQ.KSUSY1+39) GOTO 140
          IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
     &    GOTO 140
        ENDIF
        NP=NP+1
        PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
        PWT=1D0
        IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
     &  MAX(1D-10,PA)**(PARU(41)-2D0)
        DO 130 J1=1,3
          DO 120 J2=J1,3
            SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
  120     CONTINUE
  130   CONTINUE
        PS=PS+PWT*PA**2
  140 CONTINUE

C...Very low multiplicities (0 or 1) not considered.
      IF(NP.LE.1) THEN
        CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
        SPH=-1D0
        APL=-1D0
        RETURN
      ENDIF
      DO 160 J1=1,3
        DO 150 J2=J1,3
          SM(J1,J2)=SM(J1,J2)/PS
  150   CONTINUE
  160 CONTINUE

C...Find eigenvalues to matrix (third degree equation).
      SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
     &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
      SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
     &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
     &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
      SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
      P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
      P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
      P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
      IF(P(N+2,4).LT.1D-5) THEN
        CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
        SPH=-1D0
        APL=-1D0
        RETURN
      ENDIF

C...Find first and last eigenvector by solving equation system.
      DO 240 I=1,3,2
        DO 180 J1=1,3
          SV(J1,J1)=SM(J1,J1)-P(N+I,4)
          DO 170 J2=J1+1,3
            SV(J1,J2)=SM(J1,J2)
            SV(J2,J1)=SM(J1,J2)
  170     CONTINUE
  180   CONTINUE
        SMAX=0D0
        DO 200 J1=1,3
          DO 190 J2=1,3
            IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
            JA=J1
            JB=J2
            SMAX=ABS(SV(J1,J2))
  190     CONTINUE
  200   CONTINUE
        SMAX=0D0
        DO 220 J3=JA+1,JA+2
          J1=J3-3*((J3-1)/3)
          RL=SV(J1,JB)/SV(JA,JB)
          DO 210 J2=1,3
            SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
            IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
            JC=J1
            SMAX=ABS(SV(J1,J2))
  210     CONTINUE
  220   CONTINUE
        JB1=JB+1-3*(JB/3)
        JB2=JB+2-3*((JB+1)/3)
        P(N+I,JB1)=-SV(JC,JB2)
        P(N+I,JB2)=SV(JC,JB1)
        P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
     &  SV(JA,JB)
        PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
        SGN=(-1D0)**INT(PYR(0)+0.5D0)
        DO 230 J=1,3
          P(N+I,J)=SGN*P(N+I,J)/PA
  230   CONTINUE
  240 CONTINUE

C...Middle axis orthogonal to other two. Fill other codes.
      SGN=(-1D0)**INT(PYR(0)+0.5D0)
      P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
      P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
      P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
      DO 260 I=1,3
        K(N+I,1)=31
        K(N+I,2)=95
        K(N+I,3)=I
        K(N+I,4)=0
        K(N+I,5)=0
        P(N+I,5)=0D0
        DO 250 J=1,5
          V(I,J)=0D0
  250   CONTINUE
  260 CONTINUE

C...Calculate sphericity and aplanarity. Select storing option.
      SPH=1.5D0*(P(N+2,4)+P(N+3,4))
      APL=1.5D0*P(N+3,4)
      MSTU(61)=N+1
      MSTU(62)=NP
      IF(MSTU(43).LE.1) MSTU(3)=3
      IF(MSTU(43).GE.2) N=N+3

      RETURN
      END


!
!     ------------------------------------------------------------------
!              S H I F T
!     ------------------------------------------------------------------
!
!
!       Computes the mass velocity  and one-body   Darwin term
!   corrections for the relativistic shift in the energy of the electron
!   including non-diagonal corrections
!
!
      DOUBLE PRECISION FUNCTION RLSHFT (I1, I2)
      use param_C
      use radial_C
      use nel_C
!
!
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!...Translated by Pacific-Sierra Research 77to90  4.3E  00:43:46  11/16/01
!...Switches:
!
!      PARAMETER(NOD=220)
!      COMMON/PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
!     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
!      COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
!      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
!     :       (IQMAX,MAX_(1))
!      COMMON/NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7)
!
!  *****  FORM DD  -L(L+1)/RR|P(I)>
!
      FL = L(I1)
      C = (FL + D5)**2
      LL = L(I1) + 1
      L2 = 2*L(I1) + 1
      L3 = 2*L(I1) + 3
      ZZ = Z*Z
      HH = 180.D0*H*H
      MX = MAX0(MAX_(I1),MAX_(I2))
      DO J = 2, MX
         YK(J) = -D1/RR(J)
      END DO
!
!  *****  FORM THE INTEGRAND
!
      I = I1
      A1 = D0
      B1 = D0
      DO KK = 1, 2
         B2 = B1
         B1 = YK(4)
         YY = (P(3,I)+P(1,I)-D2*P(2,I))/(H*H) - C*P(2,I)
         YK(2) = YY*YK(2)
         YK(3) = YK(3)*(((-(P(5,I)+P(1,I)))+D16*(P(4,I)+P(2,I))-D30*P(3,I))/(&
            D12*H*H)-C*P(3,I))
         MM = MAX_(I) - 3
         DO K = 4, MM
            YY = D2*(P(K+3,I)+P(K-3,I))
            YY = YY - 27.D0*(P(K+2,I)+P(K-2,I))
            YY = YY + 270.D0*(P(K+1,I)+P(K-1,I)) - 490.D0*P(K,I)
            YY = YY/HH - C*P(K,I)
            YK(K) = YY*YK(K)
         END DO
         B1 = (YK(4)/(B1*(D2*Z*P(4,I)*R(4)))+D1)/R(4)
         MM = MM + 1
         YK(MM) = YK(MM)*(((-(P(MM+2,I)+P(MM-2,I)))+D16*(P(MM+1,I)+P(MM-1,I))-&
            D30*P(MM,I))/(D12*H*H)-C*P(MM,I))
         MM = MM + 1
         YK(MM) = YK(MM)*((P(MM+1,I)+P(MM-1,I)-D2*P(MM,I))/(H*H)-C*P(MM,I))
         A2 = A1
         A1 = (P(1,I)/(AZ(I)*R(1)**L(I)*R2(1))-D1+Z*R(1)/LL)/RR(1)
         I = I2
      END DO
!
!  ***** DETERMINE CONTRIBUTION FROM NEAR THE NUCLEUS
!
      A = (Z/LL - L2*(B1 + B2)/D2)/LL
      B = (L2*B1*B2 - D2*(A1 + A2) + (Z/LL**2)*(D2*Z*(D1 + D1/LL) - L2*(B1 + B2&
         )))/L3
      RELSH = -P(4,I1)*P(4,I2)*(D1 + A*R(4)+B*RR(4))*D4*ZZ/L2
      RELSH = RELSH/H1 - D5*YK(4)
      RELSH2 = D0
!
!  *****  INTEGRATE
!
      DO J = 5, MX, 2
         RELSH2 = RELSH2 + YK(J)
         RELSH = RELSH + YK(J-1)
      END DO
      RELSH = (RELSH + D2*RELSH2)*H1
      IF (L(I1) .EQ. 0) RELSH = RELSH + Z*AZ(I1)*AZ(I2)
      RLSHFT = RELSH*D5*FINE
      RETURN
      END FUNCTION RLSHFT


      subroutine runCY_00lll(k,l,Xtwiddle,Gtwiddle,Shat5,N0)
      implicit none
C---  Expression for Eq. 5.60a
C---  Calculates C00lll
C---  Small terms of order Xtwiddle(0,k)*Ciiii,Xtwiddle(0,0)*Ciiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat5(np,z4max,-2:0)

      do ep=-2,0

      Cv(czziii(z3(l,l,l))+N0,ep)=
     . (Gtwiddle(k,1)*Shat5(1,z4(l,l,l,l),ep)
     . +Gtwiddle(k,2)*Shat5(2,z4(l,l,l,l),ep)
     . +Xtwiddle(0,k)*Cv(ciiii(z4(l,l,l,l))+N0,ep)
     . -Xtwiddle(0,0)*Cv(ciiiii(z5(k,l,l,l,l))+N0,ep))/(8*Gtwiddle(k,l))
      enddo

      return
      end


      SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
     $                   RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
     $                   NAB, WORK, IWORK, INFO )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
      REAL               ABSTOL, PIVMIN, RELTOL
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * ), NAB( MMAX, * ), NVAL( * )
      REAL               AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  SLAEBZ contains the iteration loops which compute and use the
*  function N(w), which is the count of eigenvalues of a symmetric
*  tridiagonal matrix T less than or equal to its argument  w.  It
*  performs a choice of two types of loops:
*
*  IJOB=1, followed by
*  IJOB=2: It takes as input a list of intervals and returns a list of
*          sufficiently small intervals whose union contains the same
*          eigenvalues as the union of the original intervals.
*          The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
*          The output interval (AB(j,1),AB(j,2)] will contain
*          eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
*
*  IJOB=3: It performs a binary search in each input interval
*          (AB(j,1),AB(j,2)] for a point  w(j)  such that
*          N(w(j))=NVAL(j), and uses  C(j)  as the starting point of
*          the search.  If such a w(j) is found, then on output
*          AB(j,1)=AB(j,2)=w.  If no such w(j) is found, then on output
*          (AB(j,1),AB(j,2)] will be a small interval containing the
*          point where N(w) jumps through NVAL(j), unless that point
*          lies outside the initial interval.
*
*  Note that the intervals are in all cases half-open intervals,
*  i.e., of the form  (a,b] , which includes  b  but not  a .
*
*  To avoid underflow, the matrix should be scaled so that its largest
*  element is no greater than  overflow**(1/2) * underflow**(1/4)
*  in absolute value.  To assure the most accurate computation
*  of small eigenvalues, the matrix should be scaled to be
*  not much smaller than that, either.
*
*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
*  Matrix", Report CS41, Computer Science Dept., Stanford
*  University, July 21, 1966
*
*  Note: the arguments are, in general, *not* checked for unreasonable
*  values.
*
*  Arguments
*  =========
*
*  IJOB    (input) INTEGER
*          Specifies what is to be done:
*          = 1:  Compute NAB for the initial intervals.
*          = 2:  Perform bisection iteration to find eigenvalues of T.
*          = 3:  Perform bisection iteration to invert N(w), i.e.,
*                to find a point which has a specified number of
*                eigenvalues of T to its left.
*          Other values will cause SLAEBZ to return with INFO=-1.
*
*  NITMAX  (input) INTEGER
*          The maximum number of "levels" of bisection to be
*          performed, i.e., an interval of width W will not be made
*          smaller than 2^(-NITMAX) * W.  If not all intervals
*          have converged after NITMAX iterations, then INFO is set
*          to the number of non-converged intervals.
*
*  N       (input) INTEGER
*          The dimension n of the tridiagonal matrix T.  It must be at
*          least 1.
*
*  MMAX    (input) INTEGER
*          The maximum number of intervals.  If more than MMAX intervals
*          are generated, then SLAEBZ will quit with INFO=MMAX+1.
*
*  MINP    (input) INTEGER
*          The initial number of intervals.  It may not be greater than
*          MMAX.
*
*  NBMIN   (input) INTEGER
*          The smallest number of intervals that should be processed
*          using a vector loop.  If zero, then only the scalar loop
*          will be used.
*
*  ABSTOL  (input) REAL
*          The minimum (absolute) width of an interval.  When an
*          interval is narrower than ABSTOL, or than RELTOL times the
*          larger (in magnitude) endpoint, then it is considered to be
*          sufficiently small, i.e., converged.  This must be at least
*          zero.
*
*  RELTOL  (input) REAL
*          The minimum relative width of an interval.  When an interval
*          is narrower than ABSTOL, or than RELTOL times the larger (in
*          magnitude) endpoint, then it is considered to be
*          sufficiently small, i.e., converged.  Note: this should
*          always be at least radix*machine epsilon.
*
*  PIVMIN  (input) REAL
*          The minimum absolute value of a "pivot" in the Sturm
*          sequence loop.  This *must* be at least  max |e(j)**2| *
*          safe_min  and at least safe_min, where safe_min is at least
*          the smallest number that can divide one without overflow.
*
*  D       (input) REAL array, dimension (N)
*          The diagonal elements of the tridiagonal matrix T.
*
*  E       (input) REAL array, dimension (N)
*          The offdiagonal elements of the tridiagonal matrix T in
*          positions 1 through N-1.  E(N) is arbitrary.
*
*  E2      (input) REAL array, dimension (N)
*          The squares of the offdiagonal elements of the tridiagonal
*          matrix T.  E2(N) is ignored.
*
*  NVAL    (input/output) INTEGER array, dimension (MINP)
*          If IJOB=1 or 2, not referenced.
*          If IJOB=3, the desired values of N(w).  The elements of NVAL
*          will be reordered to correspond with the intervals in AB.
*          Thus, NVAL(j) on output will not, in general be the same as
*          NVAL(j) on input, but it will correspond with the interval
*          (AB(j,1),AB(j,2)] on output.
*
*  AB      (input/output) REAL array, dimension (MMAX,2)
*          The endpoints of the intervals.  AB(j,1) is  a(j), the left
*          endpoint of the j-th interval, and AB(j,2) is b(j), the
*          right endpoint of the j-th interval.  The input intervals
*          will, in general, be modified, split, and reordered by the
*          calculation.
*
*  C       (input/output) REAL array, dimension (MMAX)
*          If IJOB=1, ignored.
*          If IJOB=2, workspace.
*          If IJOB=3, then on input C(j) should be initialized to the
*          first search point in the binary search.
*
*  MOUT    (output) INTEGER
*          If IJOB=1, the number of eigenvalues in the intervals.
*          If IJOB=2 or 3, the number of intervals output.
*          If IJOB=3, MOUT will equal MINP.
*
*  NAB     (input/output) INTEGER array, dimension (MMAX,2)
*          If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
*          If IJOB=2, then on input, NAB(i,j) should be set.  It must
*             satisfy the condition:
*             N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
*             which means that in interval i only eigenvalues
*             NAB(i,1)+1,...,NAB(i,2) will be considered.  Usually,
*             NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with
*             IJOB=1.
*             On output, NAB(i,j) will contain
*             max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
*             the input interval that the output interval
*             (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
*             the input values of NAB(k,1) and NAB(k,2).
*          If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
*             unless N(w) > NVAL(i) for all search points  w , in which
*             case NAB(i,1) will not be modified, i.e., the output
*             value will be the same as the input value (modulo
*             reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
*             for all search points  w , in which case NAB(i,2) will
*             not be modified.  Normally, NAB should be set to some
*             distinctive value(s) before SLAEBZ is called.
*
*  WORK    (workspace) REAL array, dimension (MMAX)
*          Workspace.
*
*  IWORK   (workspace) INTEGER array, dimension (MMAX)
*          Workspace.
*
*  INFO    (output) INTEGER
*          = 0:       All intervals converged.
*          = 1--MMAX: The last INFO intervals did not converge.
*          = MMAX+1:  More than MMAX intervals were generated.
*
*  Further Details
*  ===============
*
*      This routine is intended to be called only by other LAPACK
*  routines, thus the interface is less user-friendly.  It is intended
*  for two purposes:
*
*  (a) finding eigenvalues.  In this case, SLAEBZ should have one or
*      more initial intervals set up in AB, and SLAEBZ should be called
*      with IJOB=1.  This sets up NAB, and also counts the eigenvalues.
*      Intervals with no eigenvalues would usually be thrown out at
*      this point.  Also, if not all the eigenvalues in an interval i
*      are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
*      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
*      eigenvalue.  SLAEBZ is then called with IJOB=2 and MMAX
*      no smaller than the value of MOUT returned by the call with
*      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1
*      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
*      tolerance specified by ABSTOL and RELTOL.
*
*  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
*      In this case, start with a Gershgorin interval  (a,b).  Set up
*      AB to contain 2 search intervals, both initially (a,b).  One
*      NVAL element should contain  f-1  and the other should contain  l
*      , while C should contain a and b, resp.  NAB(i,1) should be -1
*      and NAB(i,2) should be N+1, to flag an error if the desired
*      interval does not lie in (a,b).  SLAEBZ is then called with
*      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals --
*      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
*      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
*      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and
*      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and
*      w(l-r)=...=w(l+k) are handled similarly.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, TWO, HALF
      PARAMETER          ( ZERO = 0.0E0, TWO = 2.0E0,
     $                   HALF = 1.0E0 / TWO )
*     ..
*     .. Local Scalars ..
      INTEGER            ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
     $                   KLNEW
      REAL               TMP1, TMP2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Check for Errors
*
      INFO = 0
      IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
         INFO = -1
         RETURN
      END IF
*
*     Initialize NAB
*
      IF( IJOB.EQ.1 ) THEN
*
*        Compute the number of eigenvalues in the initial intervals.
*
         MOUT = 0
CDIR$ NOVECTOR
         DO 30 JI = 1, MINP
            DO 20 JP = 1, 2
               TMP1 = D( 1 ) - AB( JI, JP )
               IF( ABS( TMP1 ).LT.PIVMIN )
     $            TMP1 = -PIVMIN
               NAB( JI, JP ) = 0
               IF( TMP1.LE.ZERO )
     $            NAB( JI, JP ) = 1
*
               DO 10 J = 2, N
                  TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
                  IF( ABS( TMP1 ).LT.PIVMIN )
     $               TMP1 = -PIVMIN
                  IF( TMP1.LE.ZERO )
     $               NAB( JI, JP ) = NAB( JI, JP ) + 1
   10          CONTINUE
   20       CONTINUE
            MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
   30    CONTINUE
         RETURN
      END IF
*
*     Initialize for loop
*
*     KF and KL have the following meaning:
*        Intervals 1,...,KF-1 have converged.
*        Intervals KF,...,KL  still need to be refined.
*
      KF = 1
      KL = MINP
*
*     If IJOB=2, initialize C.
*     If IJOB=3, use the user-supplied starting point.
*
      IF( IJOB.EQ.2 ) THEN
         DO 40 JI = 1, MINP
            C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
   40    CONTINUE
      END IF
*
*     Iteration loop
*
      DO 130 JIT = 1, NITMAX
*
*        Loop over intervals
*
         IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
*
*           Begin of Parallel Version of the loop
*
            DO 60 JI = KF, KL
*
*              Compute N(c), the number of eigenvalues less than c
*
               WORK( JI ) = D( 1 ) - C( JI )
               IWORK( JI ) = 0
               IF( WORK( JI ).LE.PIVMIN ) THEN
                  IWORK( JI ) = 1
                  WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
               END IF
*
               DO 50 J = 2, N
                  WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
                  IF( WORK( JI ).LE.PIVMIN ) THEN
                     IWORK( JI ) = IWORK( JI ) + 1
                     WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
                  END IF
   50          CONTINUE
   60       CONTINUE
*
            IF( IJOB.LE.2 ) THEN
*
*              IJOB=2: Choose all intervals containing eigenvalues.
*
               KLNEW = KL
               DO 70 JI = KF, KL
*
*                 Insure that N(w) is monotone
*
                  IWORK( JI ) = MIN( NAB( JI, 2 ),
     $                          MAX( NAB( JI, 1 ), IWORK( JI ) ) )
*
*                 Update the Queue -- add intervals if both halves
*                 contain eigenvalues.
*
                  IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
*
*                    No eigenvalue in the upper interval:
*                    just use the lower interval.
*
                     AB( JI, 2 ) = C( JI )
*
                  ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
*
*                    No eigenvalue in the lower interval:
*                    just use the upper interval.
*
                     AB( JI, 1 ) = C( JI )
                  ELSE
                     KLNEW = KLNEW + 1
                     IF( KLNEW.LE.MMAX ) THEN
*
*                       Eigenvalue in both intervals -- add upper to
*                       queue.
*
                        AB( KLNEW, 2 ) = AB( JI, 2 )
                        NAB( KLNEW, 2 ) = NAB( JI, 2 )
                        AB( KLNEW, 1 ) = C( JI )
                        NAB( KLNEW, 1 ) = IWORK( JI )
                        AB( JI, 2 ) = C( JI )
                        NAB( JI, 2 ) = IWORK( JI )
                     ELSE
                        INFO = MMAX + 1
                     END IF
                  END IF
   70          CONTINUE
               IF( INFO.NE.0 )
     $            RETURN
               KL = KLNEW
            ELSE
*
*              IJOB=3: Binary search.  Keep only the interval containing
*                      w   s.t. N(w) = NVAL
*
               DO 80 JI = KF, KL
                  IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
                     AB( JI, 1 ) = C( JI )
                     NAB( JI, 1 ) = IWORK( JI )
                  END IF
                  IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
                     AB( JI, 2 ) = C( JI )
                     NAB( JI, 2 ) = IWORK( JI )
                  END IF
   80          CONTINUE
            END IF
*
         ELSE
*
*           End of Parallel Version of the loop
*
*           Begin of Serial Version of the loop
*
            KLNEW = KL
            DO 100 JI = KF, KL
*
*              Compute N(w), the number of eigenvalues less than w
*
               TMP1 = C( JI )
               TMP2 = D( 1 ) - TMP1
               ITMP1 = 0
               IF( TMP2.LE.PIVMIN ) THEN
                  ITMP1 = 1
                  TMP2 = MIN( TMP2, -PIVMIN )
               END IF
*
*              A series of compiler directives to defeat vectorization
*              for the next loop
*
*$PL$ CMCHAR=' '
CDIR$          NEXTSCALAR
C$DIR          SCALAR
CDIR$          NEXT SCALAR
CVD$L          NOVECTOR
CDEC$          NOVECTOR
CVD$           NOVECTOR
*VDIR          NOVECTOR
*VOCL          LOOP,SCALAR
CIBM           PREFER SCALAR
*$PL$ CMCHAR='*'
*
               DO 90 J = 2, N
                  TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
                  IF( TMP2.LE.PIVMIN ) THEN
                     ITMP1 = ITMP1 + 1
                     TMP2 = MIN( TMP2, -PIVMIN )
                  END IF
   90          CONTINUE
*
               IF( IJOB.LE.2 ) THEN
*
*                 IJOB=2: Choose all intervals containing eigenvalues.
*
*                 Insure that N(w) is monotone
*
                  ITMP1 = MIN( NAB( JI, 2 ),
     $                    MAX( NAB( JI, 1 ), ITMP1 ) )
*
*                 Update the Queue -- add intervals if both halves
*                 contain eigenvalues.
*
                  IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
*
*                    No eigenvalue in the upper interval:
*                    just use the lower interval.
*
                     AB( JI, 2 ) = TMP1
*
                  ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
*
*                    No eigenvalue in the lower interval:
*                    just use the upper interval.
*
                     AB( JI, 1 ) = TMP1
                  ELSE IF( KLNEW.LT.MMAX ) THEN
*
*                    Eigenvalue in both intervals -- add upper to queue.
*
                     KLNEW = KLNEW + 1
                     AB( KLNEW, 2 ) = AB( JI, 2 )
                     NAB( KLNEW, 2 ) = NAB( JI, 2 )
                     AB( KLNEW, 1 ) = TMP1
                     NAB( KLNEW, 1 ) = ITMP1
                     AB( JI, 2 ) = TMP1
                     NAB( JI, 2 ) = ITMP1
                  ELSE
                     INFO = MMAX + 1
                     RETURN
                  END IF
               ELSE
*
*                 IJOB=3: Binary search.  Keep only the interval
*                         containing  w  s.t. N(w) = NVAL
*
                  IF( ITMP1.LE.NVAL( JI ) ) THEN
                     AB( JI, 1 ) = TMP1
                     NAB( JI, 1 ) = ITMP1
                  END IF
                  IF( ITMP1.GE.NVAL( JI ) ) THEN
                     AB( JI, 2 ) = TMP1
                     NAB( JI, 2 ) = ITMP1
                  END IF
               END IF
  100       CONTINUE
            KL = KLNEW
*
*           End of Serial Version of the loop
*
         END IF
*
*        Check for convergence
*
         KFNEW = KF
         DO 110 JI = KF, KL
            TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
            TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
            IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
     $          NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
*
*              Converged -- Swap with position KFNEW,
*                           then increment KFNEW
*
               IF( JI.GT.KFNEW ) THEN
                  TMP1 = AB( JI, 1 )
                  TMP2 = AB( JI, 2 )
                  ITMP1 = NAB( JI, 1 )
                  ITMP2 = NAB( JI, 2 )
                  AB( JI, 1 ) = AB( KFNEW, 1 )
                  AB( JI, 2 ) = AB( KFNEW, 2 )
                  NAB( JI, 1 ) = NAB( KFNEW, 1 )
                  NAB( JI, 2 ) = NAB( KFNEW, 2 )
                  AB( KFNEW, 1 ) = TMP1
                  AB( KFNEW, 2 ) = TMP2
                  NAB( KFNEW, 1 ) = ITMP1
                  NAB( KFNEW, 2 ) = ITMP2
                  IF( IJOB.EQ.3 ) THEN
                     ITMP1 = NVAL( JI )
                     NVAL( JI ) = NVAL( KFNEW )
                     NVAL( KFNEW ) = ITMP1
                  END IF
               END IF
               KFNEW = KFNEW + 1
            END IF
  110    CONTINUE
         KF = KFNEW
*
*        Choose Midpoints
*
         DO 120 JI = KF, KL
            C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
  120    CONTINUE
*
*        If no more intervals to refine, quit.
*
         IF( KF.GT.KL )
     $      GO TO 140
  130 CONTINUE
*
*     Converged
*
  140 CONTINUE
      INFO = MAX( KL+1-KF, 0 )
      MOUT = KL
*
      RETURN
*
*     End of SLAEBZ
*
      END


      subroutine drotg(da,db,c,s)
c
c     construct givens plane rotation.
c     jack dongarra, linpack, 3/11/78.
c                    modified 9/27/86.
c
      double precision da,db,c,s,roe,scale,r,z
c
      roe = db
      if( dabs(da) .gt. dabs(db) ) roe = da
      scale = dabs(da) + dabs(db)
      if( scale .ne. 0.0d0 ) go to 10
         c = 1.0d0
         s = 0.0d0
         r = 0.0d0
         go to 20
   10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2)
      r = dsign(1.0d0,roe)*r
      c = da/r
      s = db/r
   20 z = s
      if( dabs(c) .gt. 0.0d0 .and. dabs(c) .le. s ) z = 1.0d0/c
      da = r
      db = z
      return
      end

c $Id$


module ConstantsPHMFModule

  public

  integer, parameter :: LENCTYPE = 30
  integer, parameter :: LENOBSNAMENEW = 40

  double precision, parameter :: BIGHKVALUE = 1.0d20
  double precision, parameter :: HUGEDBL = huge(1.0d0)
  double precision, parameter :: HNOFLODEFAULT = 1.d30
  double precision, parameter :: HDRYDEFAULT = 2.d30

    ! File codes
  integer, parameter :: FCUNKNOWN  = 0  ! default--not to be listed in a name file
  ! Input
  integer, parameter :: FCINPUT    = 1  ! ascii MF6 input file (named type)
  integer, parameter :: FCDATAIN   = 2  ! ascii DATA file for MF6 input
  integer, parameter :: FCDATABIN  = 3  ! DATA(BINARY) file for MF6 input
  ! Output
  integer, parameter :: FCOUTPUT   = 4  ! MF6 output file (named type)
  integer, parameter :: FCDATAOUT  = 5  ! ascii DATA file for MF6 output
  integer, parameter :: FCDATABOUT = 6  ! DATA(BINARY) file for MF6 output

  ! Obs file formats
  integer, parameter :: SINGLE     = 1
  integer, parameter :: CONTINUOUS = 2

  ! Trig
  double precision, parameter :: PI = 4.D0*ATAN(1.D0)
  double precision, parameter :: DEGREES_TO_RADIANS = PI/180.0d0

end module ConstantsPHMFModule


program stats_test
    use, intrinsic :: iso_fortran_env, only : f8 => REAL64
    use :: stats_private_mod
    implicit none
    integer, parameter :: n = 10
    integer :: i
    real(kind=f8), dimension(n) :: data = [ ((0.5_f8*i), i = 1, n) ]
    type(stats_type) :: my_stats
    my_stats = new_stats()
    do i = 1, n
        call my_stats%add(data(i))
    end do
    print '(A, F10.2)', 'average =', my_stats%avg()
    my_stats%n = 5
    print '(A, F10.2)', 'average =', my_stats%avg()
end program stats_test


!##############################################
!##############################################
!######                                ########
!######       PROGRAM RCPF.f90         ########
!######       Author: Haidi Yang       ########
!######       Time: 04/25/2020         ########
!######       UPC                      ########
!######       Ver 1.1-2                ########
!######                                ########
!##############################################
!##############################################

program RCPF
implicit none
! RCPF : R - RSG, CP - CPML, F - Free surface
! 2D biot rotated-staggered-grid finite-difference code in velocity-stress formulation
! with convolution PML (CPML) absorbing conditions for an isotropic medium.

! For stress at grid point, and velocity at half grid

! x8t2
! for Free surface, it should be processed with specially attention besides setting the velocity to zero, density to small number close to zero.

! in isotropic medium, averaging the parameter is not needed. But in inhomogeneous medium, should averaging the parameter.

	character*77 parfile
	character*77 fname
    integer*4 nx,nz,nt,xs,zs,np,iw,dst,iwav
	real*4 dx,dz,dt,vmax,r,chi0,a0,f0,ew,power_display,cutvect
	integer*4 nr,fxr,fzr,dxr,dzr
	integer*4 ifs,fslc
	integer*4 ifa,sl
    real*4 pi
	real*4 c1,c2,c3,c4
    real*4 dr,maxpar
	real*4 d0,alphamax
    real*4 ts,refdist,Courant_number
    integer*4 ix,iz,it,i

	real*4,allocatable,dimension(:,:) :: rho
	real*4,allocatable,dimension(:,:) :: c11,c12,c13,c22,c23,c33
    real*4,allocatable,dimension(:,:) :: rhoxz
    real*4,allocatable,dimension(:,:) :: txx,txz,tzz,vx,vz
	real*4,allocatable,dimension(:,:) :: dxtxx,dztxx,dxtxz,dztxz,dxtzz,dztzz
    real*4,allocatable,dimension(:,:) :: dxvx,dzvz,dxvz,dzvx
!   parameter for CPML
	real*4,allocatable,dimension(:,:) :: ax,bx,az,bz,chix,chiz,cdx,cdz
	real*4,allocatable,dimension(:,:) :: ax_half,bx_half,az_half,bz_half,chix_half,chiz_half,cdx_half,cdz_half
    real*4,allocatable,dimension(:,:) :: psidxtxx,psidztzz,psidxtxz,psidztxz
    real*4,allocatable,dimension(:,:) :: psidxvx,psidzvx,psidxvz,psidzvz
! output velocity and stress
    real*4,allocatable,dimension(:,:) :: seisvx,seisvz
    real*4,allocatable,dimension(:,:) :: seistxx,seistzz,seistxz
    real*4,allocatable,dimension(:,:) :: wav
    real*4,allocatable,dimension(:) :: wavelet,wlet
	integer :: status=0

! cpu_time
	real time_begin,time_end

!##########################################################################################################
!##########################################################################################################
	write(*,*) 'Input the parfile name:'
	read(*,*) parfile
	print *,parfile

	open(99,file=parfile,form='formatted',access='sequential',iostat=status)
	write(*,*) status
	read(99,'(64x)')

	read(99,'(70x)')
	read(99,*) nx,nz,nt,dx,dz,dt
	write(*,*) nx,nz,nt,dx,dz,dt

	read(99,'(70x)')
	read(99,*) np,vmax,r,chi0,a0
	write(*,*) np,vmax,r,chi0,a0

	read(99,'(70x)')
	read(99,*) f0,iw,dst,iwav,power_display,cutvect
	write(*,*) f0,iw,dst,iwav,power_display,cutvect

	read(99,'(70x)')
	read(99,*) xs,zs
	write(*,*) xs,zs

	read(99,'(70x)')
	read(99,*) nr,fxr,fzr,dxr,dzr
	write(*,*) nr,fxr,fzr,dxr,dzr

	read(99,'(70x)')
	read(99,*) ifs,fslc,ifa
	write(*,*) ifs,fslc,ifa

        read(99,'(70x)')
	read(99,*) sl
	write(*,*) sl
	close(99)

    dr = sqrt(dx**2+dz**2)
    dx = 2.0*dx
    dz = 2.0*dz
	!   modify the coefficient of spatial opertor
    c1 = (1225.0/1024.0)
    c2 = c1/15.0
    c3 = c1/125.0
    c4 = c1/1715.0
    ts = 1.2/f0

	pi = 4.0*atan(1.0)
    d0 = -3*vmax*log(r)/(2.0*np*dx/2.0)
    alphamax = pi*a0

!	allocate the arrays
    allocate(rho(nz,nx),c11(nz,nx),c12(nz,nx),c13(nz,nz),c22(nz,nx),c23(nz,nx),c33(nz,nx))
	allocate(txx(nz,nx),txz(nz,nx),tzz(nz,nx),vx(nz,nx),vz(nz,nx))
	allocate(rhoxz(nz,nx))
	allocate(dxtxx(nz,nx),dztxx(nz,nx),dxtxz(nz,nx),dztxz(nz,nx),dxtzz(nz,nx),dztzz(nz,nx))
	allocate(dxvx(nz,nx),dzvz(nz,nx),dxvz(nz,nx),dzvx(nz,nx))
	allocate(ax(nz,nx),bx(nz,nx),az(nz,nx),bz(nz,nx),chix(nz,nx),chiz(nz,nx),cdx(nz,nx),cdz(nz,nx))
	allocate(ax_half(nz,nx),bx_half(nz,nx),az_half(nz,nx),bz_half(nz,nx),chix_half(nz,nx),chiz_half(nz,nx),cdx_half(nz,nx),cdz_half(nz,nx))
	allocate(psidxtxx(nz,nx),psidztzz(nz,nx),psidxtxz(nz,nx),psidztxz(nz,nx))
	allocate(psidxvx(nz,nx),psidzvx(nz,nx),psidxvz(nz,nx),psidzvz(nz,nx))
	allocate(wav(nz,nx))
	allocate(seisvx(nt,nr),seisvz(nt,nr),seistxx(nt,nr),seistzz(nt,nr),seistxz(nt,nr))
	allocate(wavelet(nt))
	allocate(wlet(nt))

	open(1,file='rho.dat',access='stream')
    open(2,file='c11.dat',access='stream')
    open(3,file='c12.dat',access='stream')
    open(4,file='c13.dat',access='stream')
    open(5,file='c22.dat',access='stream')
    open(6,file='c23.dat',access='stream')
	open(7,file='c33.dat',access='stream')
    open(8,file='wlet.dat',access='stream')
	read(1)rho
    read(2)c11
	read(3)c12
	read(4)c13
	read(5)c22
	read(6)c23
	read(7)c33
	read(8)wlet

	rho=rho*1.0e3
        c11=c11*1.0e9
	c12=c12*1.0e9
	c13=c13*1.0e9
	c22=c22*1.0e9
	c23=c23*1.0e9
	c33=c33*1.0e9
    wlet=wlet

	close(1)
	close(2)
	close(3)
	close(4)
	close(5)
	close(6)
	close(7)
	close(8)
	if(ifs .eq. 1) then
	    rho(1:fslc-1,:) = rho(1:fslc-1,:)*1.0e-3
        rho(nz:nz,:) = rho(nz:nz,:)*1.0e-3
       c11(1:fslc-1,:) = 0.0
        c12(1:fslc-1,:) = 0.0
        c13(1:fslc-1,:) = 0.0
		c22(1:fslc-1,:) = 0.0
		c23(1:fslc-1,:) = 0.0
		c33(1:fslc-1,:) = 0.0
		c11(nz:nz,:) = 0.0
        c12(nz:nz,:) = 0.0
		c13(nz:nz,:) = 0.0
		c22(nz:nz,:) = 0.0
		c23(nz:nz,:) = 0.0
		c33(nz:nz,:) = 0.0
    endif
	if(ifa .eq. 1) then
	rho(:,1:fslc-1) = rho(:,1:fslc-1)*1.0e-3
    rho(:,nx:nx) = rho(:,nx:nx)*1.0e-3

       c11(:,1:fslc-1)=0.0
       c12(:,1:fslc-1)=0.0
	   c13(:,1:fslc-1)=0.0
       c22(:,1:fslc-1)=0.0
	   c23(:,1:fslc-1)=0.0
	   c33(:,1:fslc-1)=0.0
		c11(:,nx:nx) = 0.0
		c12(:,nx:nx) = 0.0
		c13(:,nx:nx) = 0.0
		c22(:,nx:nx) = 0.0
		c23(:,nx:nx) = 0.0
		c33(:,nx:nx) = 0.0
    endif

! interpolate rho and b at half grid
    do iz=1,nz-1
        do ix=1,nx-1
        rhoxz(iz,ix) = 0.25*(rho(iz  ,ix  )+rho(iz+1,ix  )+rho(iz+1,ix+1)+rho(iz  ,ix+1))
		enddo
    enddo
	rhoxz(nz  ,1:nx-1) = 0.5*(rho(nz  ,1:nx-1)+rho(nz  ,2:nx  ))
    rhoxz(1:nz-1,nx) = 0.5*(rho(1:nz-1  ,nx  )+rho(2:nz  ,nx  ))
    rhoxz(nz,nx) = rho(nz,nx)

	if(iw .eq. 1) then
		call dgauss(wavelet,nt,dt,f0,ts)
	elseif(iw .eq. 0) then
		call ricker(wavelet,nt,dt,f0,ts)
	elseif(iw.eq. 2) then
                wavelet=wlet
	else
		wavelet = 0.0
		wavelet(1) = 1.0
    endif

    open(55,file='wavelet.dat',access='stream')
    write(55)wavelet
    close(55)
	if(iwav .eq. 1) then
		do ix = max(1,xs-3),min(nx,xs+3)
			do iz = max(1,zs-3),min(nz,zs+3)
				wav(iz,ix) = exp(-0.2*((real(iz)-zs)**2 + (real(ix)-xs)**2))
			end do
		end do
	else
		wav = 0.0
		wav(zs-2:zs+2,xs-2:xs+2) = 1.0
	endif
	open(56,file='wav.dat',access='stream')
    write(56)wav
    close(56)

! time begin
	call cpu_time(time_begin)

!---------------PML------------------------
! need vmax, so compute vmax_max first. Here assume vmax is known.

    ax = 0.0
    az = 0.0
    bx = 1.0
    bz = 1.0
    chix = 1.0
    chiz = 1.0
    cdx = 0.0
    cdz = 0.0

    ax_half = 0.0
    az_half = 0.0
    bx_half = 1.0
    bz_half = 1.0
    chix_half = 1.0
    chiz_half = 1.0
    cdx_half = 0.0
    cdz_half = 0.0

	do ix = 1,nx
	    if(ifs .eq. 0) then
	         do iz = 1,np+5
	              refdist = (np+5.0-(iz))/np
	              if(refdist > 1.0) refdist = 1.0
	              if(refdist < 0.0) refdist = 0.0
	              if(refdist >= 0.0) then
	                  chiz(iz,ix) = 1.0+(chi0-1.0)*(refdist)**2
	                  cdz(iz,ix) = d0*(refdist)**2
	                  bz(iz,ix) = exp(-(cdz(iz,ix)/chiz(iz,ix)+ alphamax*(1.0-refdist)) * dt)
	                  az(iz,ix) = cdz(iz,ix) / (chiz(iz,ix)*(cdz(iz,ix) + chiz(iz,ix)*alphamax*(1.0-refdist))) * (bz(iz,ix) - 1.0)
	              endif
	              if(ix == 1) print *,'refdist at iz=',iz,'=',refdist

	              refdist = ((np+4.5-(iz))/np)
	              if(refdist > 1.0) refdist = 1.0
	              if(refdist < 0.0) refdist = 0.0
	              if(refdist >= 0.0) then
	                   chiz_half(iz,ix) = 1.0+(chi0-1.0)*(refdist)**2
	                   cdz_half(iz,ix) = d0*(refdist)**2
	                   bz_half(iz,ix) = exp(-(cdz_half(iz,ix)/chiz_half(iz,ix)+ alphamax*(1.0-refdist)) * dt)
	                   az_half(iz,ix) = cdz_half(iz,ix) / (chiz_half(iz,ix)*(cdz_half(iz,ix) + chiz_half(iz,ix)*alphamax*(1.0-refdist))) * (bz_half(iz,ix) - 1.0)
	               endif
	               if(ix == 1) print *,'refdist half at iz=',iz,'=',refdist
	         enddo
        endif

     do iz = (nz-4-np),nz
          refdist = ((iz-0.5)-(nz-4.0-np))/np
         if(refdist > 1.0) refdist = 1.0
          if(refdist < 0.0) refdist = 0.0
          if(refdist >= 0.0) then
              chiz(iz,ix) = 1.0+(chi0-1.0)*(refdist)**2
              cdz(iz,ix) = d0*(refdist)**2
              bz(iz,ix) = exp(-(cdz(iz,ix)/chiz(iz,ix) + alphamax*(1.0-refdist)) * dt)
              az(iz,ix) = cdz(iz,ix) / (chiz(iz,ix)*(cdz(iz,ix) + chiz(iz,ix)*alphamax*(1.0-refdist))) * (bz(iz,ix) - 1.0)
         endif
         if(ix == 1) print *,'refdist at iz=',iz,'=',refdist

          refdist = (((iz-0.0)-(nz-4.0-np))/np)
         if(refdist > 1.0) refdist = 1.0
          if(refdist < 0.0) refdist = 0.0
          if(refdist >= 0.0) then
               chiz_half(iz,ix) = 1.0+(chi0-1.0)*(refdist)**2
               cdz_half(iz,ix) = d0*(refdist)**2
               bz_half(iz,ix) = exp(-(cdz_half(iz,ix)/chiz_half(iz,ix) + alphamax*(1.0-refdist)) * dt)
               az_half(iz,ix) = cdz_half(iz,ix) / (chiz_half(iz,ix)*(cdz_half(iz,ix) + chiz_half(iz,ix)*alphamax*(1.0-refdist))) * (bz_half(iz,ix) - 1.0)
          endif
          if(ix == 1) print *,'refdist half at iz=',iz,'=',refdist
     enddo
    enddo

	do iz = 1,nz
    if(ifa .eq. 0) then
	 do ix = 1,np+5
	  refdist = (np+5.0-(ix))/np
     if(refdist > 1.0) refdist = 1.0
	  if(refdist < 0.0) refdist = 0.0
	  if(refdist >= 0.0) then
	  chix(iz,ix) = 1.0+(chi0-1.0)*(refdist)**2
	  cdx(iz,ix) = d0*(refdist)**2
	  bx(iz,ix) = exp(-(cdx(iz,ix)/chix(iz,ix)+ alphamax*(1.0-refdist)) * dt)
	  ax(iz,ix) = cdx(iz,ix) / (chix(iz,ix)*(cdx(iz,ix) + chix(iz,ix)*alphamax*(1.0-refdist))) * (bx(iz,ix) - 1.0)
	 endif
	 if(iz == 1) print *,'refdist at ix=',ix,'=',refdist

	  refdist = (np+4.5-(ix))/np
     if(refdist > 1.0) refdist = 1.0
	  if(refdist < 0.0) refdist = 0.0
	  if(refdist >= 0.0) then
	   chix_half(iz,ix) = 1.0+(chi0-1.0)*(refdist)**2
	   cdx_half(iz,ix) = d0*(refdist)**2
	   bx_half(iz,ix) = exp(-(cdx_half(iz,ix)/chix_half(iz,ix)+ alphamax*(1.0-refdist)) * dt)
	   ax_half(iz,ix) = cdx_half(iz,ix) / (chix_half(iz,ix)*(cdx_half(iz,ix) + chix_half(iz,ix)*alphamax*(1.0-refdist))) * (bx_half(iz,ix) - 1.0)
	  endif
	  if(iz == 1) print *,'refdist half at ix=',ix,'=',refdist
	 enddo

	 do ix = (nx-4-np),nx
	  refdist = ((ix-0.5)-(nx-4-np))/np
     if(refdist > 1.0) refdist = 1.0
	  if(refdist < 0.0) refdist = 0.0
	  if(refdist >= 0.0) then
	  chix(iz,ix) = 1.0+(chi0-1.0)*(refdist)**2
	  cdx(iz,ix) = d0*(refdist)**2
	  bx(iz,ix) = exp(-(cdx(iz,ix)/chix(iz,ix) + alphamax*(1.0-refdist)) * dt)
	  ax(iz,ix) = cdx(iz,ix) / (chix(iz,ix)*(cdx(iz,ix) + chix(iz,ix)*alphamax*(1.0-refdist))) * (bx(iz,ix) - 1.0)
	 endif
	 if(iz == 1) print *,'refdist at ix=',ix,'=',refdist

	  refdist = ((ix+0.0)-(nx-4-np))/np
     if(refdist > 1.0) refdist = 1.0
	  if(refdist < 0.0) refdist = 0.0
	  if(refdist >= 0.0) then
	   chix_half(iz,ix) = 1.0+(chi0-1.0)*(refdist)**2
	   cdx_half(iz,ix) = d0*(refdist)**2
	   bx_half(iz,ix) = exp(-(cdx_half(iz,ix)/chix_half(iz,ix) + alphamax*(1.0-refdist)) * dt)
	   ax_half(iz,ix) = cdx_half(iz,ix) / (chix_half(iz,ix)*(cdx_half(iz,ix) + chix_half(iz,ix)*alphamax*(1.0-refdist))) * (bx_half(iz,ix) - 1.0)
	  endif
	  if(iz == 1) print *,'refdist half at ix=',ix,'=',refdist

	 enddo
	 end if
	enddo

! print position of the source
	print *,'Position of the source:'
	print *
	print *,'x = ',xs
	print *,'z = ',zs
	print *

! define location of receivers
	print *,'There are ',nr,' receivers'
	print *

	print *,'the 1st receiver: (x_target,z_target) = ',fxr,fzr
	print *,'the last receiver: (x_target,z_target) = ',fxr+real(nr-1)*dxr,fzr+real(nr-1)*dzr
	print *,'distance between receivers: (dx,dz) = ',dxr,dzr

! check the Courant stability condition for the explicit time scheme
! R. Courant et K. O. Friedrichs et H. Lewy (1928)
	Courant_number = vmax * dt / dr
	print *,'Courant number is ',Courant_number
	print *
	if(Courant_number > 1.0) then
		pause 'time step is too large, simulation will be unstable'
	endif

!-----------------------------------------------------------------------
!                   compute code
!-----------------------------------------------------------------------
! initial the initial values
	psidxtxx = 0.0
    psidztzz = 0.0
    psidxtxz = 0.0
    psidztxz = 0.0

    psidxvx = 0.0
    psidzvx = 0.0
    psidxvz = 0.0
    psidzvz = 0.0

    vx = 0.0
    vz = 0.0

	txx = 0.0
	txz = 0.0
	tzz = 0.0

	write(*,*) 'Begin time step computing ...'

	do it = 1,nt

        if(mod(it,100) .eq. 0) print *,'No. ',it,' of ',nt

!   compute the velocity of nonstiff equations
!   compute the spatial difference of stress and pressure
        dxtxx = 0.0
        dztxx = 0.0
        dxtxz = 0.0
        dztxz = 0.0
        dxtzz = 0.0
        dztzz = 0.0

        do ix=4,nx-4
            do iz=4,nz-4
                dxtxx(iz,ix) = (c1*(txx(iz  ,ix+1)-txx(iz+1,ix  )) - c2*(txx(iz-1,ix+2)-txx(iz+2,ix-1)) + c3*(txx(iz-2,ix+3)-txx(iz+3,ix-2)) -c4*(txx(iz-3,ix+4)-txx(iz+4,ix-3)))
                dztxx(iz,ix) = (c1*(txx(iz+1,ix+1)-txx(iz  ,ix  )) - c2*(txx(iz+2,ix+2)-txx(iz-1,ix-1)) + c3*(txx(iz+3,ix+3)-txx(iz-2,ix-2)) -c4*(txx(iz+4,ix+4)-txx(iz-3,ix-3)))

                dxtzz(iz,ix) = (c1*(tzz(iz  ,ix+1)-tzz(iz+1,ix  )) - c2*(tzz(iz-1,ix+2)-tzz(iz+2,ix-1)) + c3*(tzz(iz-2,ix+3)-tzz(iz+3,ix-2)) -c4*(tzz(iz-3,ix+4)-tzz(iz+4,ix-3)))
                dztzz(iz,ix) = (c1*(tzz(iz+1,ix+1)-tzz(iz  ,ix  )) - c2*(tzz(iz+2,ix+2)-tzz(iz-1,ix-1)) + c3*(tzz(iz+3,ix+3)-tzz(iz-2,ix-2)) -c4*(tzz(iz+4,ix+4)-tzz(iz-3,ix-3)))

                dxtxz(iz,ix) = (c1*(txz(iz  ,ix+1)-txz(iz+1,ix  )) - c2*(txz(iz-1,ix+2)-txz(iz+2,ix-1)) + c3*(txz(iz-2,ix+3)-txz(iz+3,ix-2)) -c4*(txz(iz-3,ix+4)-txz(iz+4,ix-3)))
                dztxz(iz,ix) = (c1*(txz(iz+1,ix+1)-txz(iz  ,ix  )) - c2*(txz(iz+2,ix+2)-txz(iz-1,ix-1)) + c3*(txz(iz+3,ix+3)-txz(iz-2,ix-2)) -c4*(txz(iz+4,ix+4)-txz(iz-3,ix-3)))

            enddo
        enddo

		 dxtxx = (dztxx+dxtxx) / dx
		 dztzz = (dztzz-dxtzz) / dz
		 dxtxz = (dztxz+dxtxz) / dx
		 dztxz = (2.0*dztxz-dx*dxtxz) / dz

! update the psi_function of stress in the CPML
		psidxtxx = bx_half*psidxtxx + ax_half*dxtxx
		psidztzz = bz_half*psidztzz + az_half*dztzz
		psidxtxz = bx_half*psidxtxz + ax_half*dxtxz
		psidztxz = bz_half*psidztxz + az_half*dztxz

! take dxtxx as dxtxx+psidxtxx
       dxtxx = dxtxx/chix_half + psidxtxx
        dztzz = dztzz/chiz_half + psidztzz
       dxtxz = dxtxz/chix_half + psidxtxz
        dztxz = dztxz/chiz_half + psidztxz

! update the x and z component of solid and fluid velocity
    	vx = vx + dt/rhoxz*((dxtxx+dztxz))
    	vz = vz + dt/rhoxz*((dxtxz+dztzz))

!   compute the stress and pressure of nonstiff equations
!   compute the spatial difference of velocity
        dxvx = 0.0
        dzvx = 0.0
        dzvz = 0.0
        dxvz = 0.0
		do ix = 5,nx-3
			do iz = 5,nz-3
			    dzvx(iz,ix) = (c1*(vx(iz  ,ix  )-vx(iz-1,ix-1)) - c2*(vx(iz+1,ix+1)-vx(iz-2,ix-2)) +c3*(vx(iz+2,ix+2)-vx(iz-3,ix-3)) -c4*(vx(iz+3,ix+3)-vx(iz-4,ix-4)))
				dxvx(iz,ix) = (c1*(vx(iz-1,ix  )-vx(iz  ,ix-1)) - c2*(vx(iz-2,ix+1)-vx(iz+1,ix-2)) +c3*(vx(iz-3,ix+2)-vx(iz+2,ix-3)) -c4*(vx(iz-4,ix+3)-vx(iz+3,ix-4)))

				dzvz(iz,ix) = (c1*(vz(iz  ,ix  )-vz(iz-1,ix-1)) - c2*(vz(iz+1,ix+1)-vz(iz-2,ix-2)) +c3*(vz(iz+2,ix+2)-vz(iz-3,ix-3)) -c4*(vz(iz+3,ix+3)-vz(iz-4,ix-4)))
				dxvz(iz,ix) = (c1*(vz(iz-1,ix  )-vz(iz  ,ix-1)) - c2*(vz(iz-2,ix+1)-vz(iz+1,ix-2)) +c3*(vz(iz-3,ix+2)-vz(iz+2,ix-3)) -c4*(vz(iz-4,ix+3)-vz(iz+3,ix-4)))

			enddo
		enddo

   dxvx = (dzvx+dxvx) / dx
   dzvx = (2.0*dzvx-dx*dxvx) / dz
   dxvz = (dzvz+dxvz) / dx
   dzvz = (2.0*dzvz-dx*dxvz) / dz

! update the psi_function of the CPML
!	the CPML parameter here is at half grid
		psidxvx = bx*psidxvx + ax*dxvx
		psidzvx = bz*psidzvx + az*dzvx
		psidxvz = bx*psidxvz + ax*dxvz
		psidzvz = bz*psidzvz + az*dzvz

! take dxvx as dxvx+psidxvx
        dxvx = dxvx/chix + psidxvx
        dzvx = dzvx/chiz + psidzvx
        dxvz = dxvz/chix + psidxvz
        dzvz = dzvz/chiz + psidzvz

! update the stress and pressure
       txx = txx + ((c11)*(dxvx) + c12*(dzvz)+c13*(dxvz+dzvx))*dt
        tzz = tzz + ((c22)*(dzvz) + c12*(dxvx)+c23*(dxvz+dzvx))*dt
        txz = txz + ((c13)*(dxvx) + c23*(dzvz)+c33*(dxvz+dzvx))*dt

! store seismograms
		do i = 1,nr
			seisvx(it,i) = vx(fzr+(i-1)*dzr,fxr+(i-1)*dxr)
			seisvz(it,i) = vz(fzr+(i-1)*dzr,fxr+(i-1)*dxr)

			seistxx(it,i) = txx(fzr+(i-1)*dzr,fxr+(i-1)*dxr)
			seistxz(it,i) = txz(fzr+(i-1)*dzr,fxr+(i-1)*dxr)
			seistzz(it,i) = tzz(fzr+(i-1)*dzr,fxr+(i-1)*dxr)

		end do
		if(sl.eq.1) then
		txx = txx + wavelet(it)*wav
!		tzz = tzz + wavelet(it)*wav
!		txz = txz + wavelet(it)*(1.0-ew)*wav/2.0

        endif
	    if(sl.eq.2) then
!		txx = txx + wavelet(it)*wav
		tzz = tzz+wavelet(it)*wav
!		txz = txz + wavelet(it)*(1.0-ew)*wav/2.0

        endif
        if(sl.eq.3) then
!		txx = txx + wavelet(it)*wav
!		tzz = tzz + wavelet(it)*wav
		txz = txz + wavelet(it)*(1.0-ew)*wav/2.0
!        p = p + wavelet(it)*wav
        endif

! output the snapshot
		if(mod(it,dst) .eq. 0) then
			print *,'Time step # ',it
			print *,'Time: ',sngl((it-1)*dt),' seconds'
			print *,'Max norm velocity vector V (m/s) = ',max(maxval(sqrt(vx**2 + vz**2)),maxval(sqrt(vz**2)))
			print *

			write(fname,"('snap_',i6.6,'_Vx.dat')") it
			maxpar = 1.0
			!maxpar = maxval(abs(vx))
			!maxpar = abs(vz(zs,xs))
!			tmp = vx(np+5:nz-4-np,np+5:nx-4-np)
			open(11,file=fname,access='stream')
			write(11) vx
			close(11)
!			call creat_2D_image(vx,nx,nz,it,xs,zs,fxr,fzr,dxr,dzr,nr,np+4,0,power_display,cutvect)
            write(fname,"('snap_',i6.6,'_Vz.dat')") it
			!maxpar = maxval(abs(vz))
			!maxpar = 1.0
!			tmp = vz(np+5:nz-4-np,np+5:nx-4-np)
			open(12,file=fname,access='stream')
			write(12) vz
			close(12)

            write(fname,"('snap_',i6.6,'_txx.dat')") it
			!maxpar = maxval(txx)
!			tmp = txx(np+5:nz-4-np,np+5:nx-4-np)
			open(15,file=fname,access='stream')
			write(15) txx
			close(15)
!			call creat_2D_image(txx,nx,nz,it,xs,zs,fxr,fzr,dxr,dzr,nr,np+4,4,power_display,cutvect)

            write(fname,"('snap_',i6.6,'_tzz.dat')") it
			!maxpar = maxval(tzz)
!			tmp = tzz(np+5:nz-4-np,np+5:nx-4-np)
			open(16,file=fname,access='stream')
			write(16) tzz
			close(16)
!			call creat_2D_image(tzz,nx,nz,it,xs,zs,fxr,fzr,dxr,dzr,nr,np+4,5,power_display,cutvect)

            write(fname,"('snap_',i6.6,'_txz.dat')") it
!			!maxpar = maxval(txz)
!			tmp = txz(np+5:nz-4-np,np+5:nx-4-np)
			open(17,file=fname,access='stream')
			write(17) txz
			close(17)
		end if

	end do

	call cpu_time(time_end)
	write(*,*) 'Time of operation was ',time_end-time_begin,' seconds'

!   write the seismgram
    open(109,file='seisvz.dat',access='stream')
    write(109) seisvz
    close(109)

	open(111,file='seisvx.dat',access='stream')
    write(111) seisvx
    close(111)

	open(114,file='seistxx.dat',access='stream')
    write(114) seistxx
    close(114)

	open(116,file='seistzz.dat',access='stream')
    write(116) seistzz
    close(116)

    deallocate(rhoxz)
	deallocate(txx,txz,tzz,vx,vz,seisvx,seisvz,seistxx,seistzz,seistxz)
	deallocate(dxtxx,dztxx,dxtxz,dztxz,dxtzz,dztzz,dxvx,dzvz,dxvz,dzvx)
	deallocate(psidxtxx,psidztzz,psidxtxz,psidztxz,psidzvx,psidxvz,psidzvz)
	deallocate(ax,bx,az,bz,chix,chiz,cdx,cdz,ax_half,bx_half,az_half,bz_half,chix_half,chiz_half,cdx_half,cdz_half)
	deallocate(wavelet,wav)

	print *
	print *,'End of the simulation'
	pause
	print *

end program
!*********************************
!*     END
!*********************************

!*********************************
!*     Ricker Wavelet
!*********************************
      subroutine ricker(wv,nt,dt,f0,ts)
	  integer*4 nt
      real*4 wv(nt)
      real*4 aa,dt,f0,ts,pi
      integer ii

!cccccccccccccccccccccccccccccccccccccccc
    pi=4.*atan(1.0)
    do ii=1,nt
        aa=pi*f0*((ii-1.)*dt-ts)
        aa=aa*aa
        wv(ii)=(1.-2.*aa)*exp(-aa)
    enddo
!c---------------------------------------
      return
      end subroutine

!*********************************
!*     dgauss wavelet
!*********************************
    subroutine dgauss(wv,nt,dt,f0,ts)
	integer*4 nt
    real*4 wv(nt)
    real*4 aa,dt,f0,ts,pi
    integer ii
!cccccccccccccccccccccccccccccccccccccccc
    pi = 4. * atan(1.0)
    do ii=1,nt
        aa = pi*f0*pi*f0

        wv(ii) = -2.0*aa*((ii-1)*dt-ts)*exp(-aa*((ii-1)*dt-ts)**2)
    end do
!cccccccccccccccccccccccccccccccccccccccc
    return
    end subroutine

!*********************************
!*     draw the snapshot
!*********************************
	subroutine creat_2D_image(sndat,nx,nz,it,xs,zs,fxr,fzr,dxr,dzr,nr,np,ifield,power_display,cutvect)
	implicit none
!	real,parameter :: power_display=0.2
!	real,parameter :: cutvect=0.05
	logical,parameter :: white_background=.true.
	integer,parameter :: width_cross=5,thickness_cross=1,size_square=3

		integer nx,nz,it,xs,zs,fxr,fzr,dxr,dzr,np,nr
		real,dimension(nz,nx) :: sndat
		!integer,dimension(nr) :: xr,zr
		integer :: ix,iz,irec
		character(len=100) :: fname,system_command
		integer :: R,G,B
		real :: normalized,maxamp
		integer :: ifield
		real :: power_display,cutvect

		if(ifield .eq. 0) then
			write(fname,"('image',i6.6,'_Vz.pnm')") it
			write(system_command,"('convert image',i6.6,'_Vz.pnm image',i6.6, &
				'_Vz.tif ; rm image',i6.6,'_Vz.pnm')") it,it,it
		else
			write(fname,"('image',i6.6,'_p.pnm')") it
			write(system_command,"('convert image',i6.6,'_p.pnm image',i6.6, &
				'_p.tif ; rm image',i6.6,'_p.pnm')") it,it,it
		endif

		open(unit=27, file=fname, status='unknown')

		write(27,"('P3')") ! write image in PNM P3 format

		write(27,*) nx,nz ! write image size
		write(27,*) '255' ! maximum value of each pixel color

! compute maximum amplitude
		maxamp = maxval(abs(sndat))

! image starts in upper-left corner in PNM format
		  do iz=nz,1,-1
			do ix=1,nx

! define data as vector component normalized to [-1:1] and rounded to nearest integer
! keeping in mind that amplitude can be negative
				normalized = sndat(iz,ix) / maxamp

! suppress values that are outside [-1:+1] to avoid small edge effects
				if(normalized < -1.0) normalized = -1.0
				if(normalized > 1.0) normalized = 1.0

! draw an orange cross to represent the source
				if((ix >= xs - width_cross .and. ix <= xs + width_cross .and. &
					iz >= zs - thickness_cross .and. iz <= zs + thickness_cross) .or. &
					(ix >= xs - thickness_cross .and. ix <= xs + thickness_cross .and. &
					iz >= zs - width_cross .and. iz <= zs + width_cross)) then
						 R = 255
						 G = 157
						 B = 0

! display two-pixel-thick black frame around the image
				else if(ix <= 2 .or. ix >= nx-1 .or. iz <= 2 .or. iz >= nz-1) then
						R = 0
						G = 0
						B = 0

! display edges of the PML layers
				else if((ix == np) .or. &
					(ix == nx - np) .or. &
					(iz == np) .or. &
					(iz == nz - np)) then
						R = 255
						G = 150
						B = 0

! suppress all the values that are below the threshold
				else if(abs(normalized) <= cutvect) then

! use a black or white background for points that are below the threshold
					if(white_background) then
						R = 255
						G = 255
						B = 255
					else
						R = 0
						G = 0
						B = 0
					endif

! represent regular image points using red if value is positive, blue if negative
				else if(normalized >= 0.0) then
					R = nint(255.0*normalized**power_display)
					G = 0
					B = 0
				else
					R = 0
					G = 0
					B = nint(255.0*abs(normalized)**power_display)
				endif

! draw a green square to represent the receivers
				do irec = 1,nr
					if((ix >= fxr+(irec-1)*dxr - size_square .and. ix <= fxr+(irec-1)*dxr  + size_square .and. &
						iz >= fzr+(irec-1)*dzr - size_square .and. iz <= fzr+(irec-1)*dzr + size_square) .or. &
						(ix >= fxr+(irec-1)*dxr  - size_square .and. ix <= fxr+(irec-1)*dxr  + size_square .and. &
						iz >= fzr+(irec-1)*dzr  - size_square .and. iz <= fzr+(irec-1)*dzr + size_square)) then
! use dark green color
							R = 30
							G = 180
							B = 60
					endif
				enddo

! write color pixel
				write(27,"(i3,' ',i3,' ',i3)") R,G,B

			enddo
		enddo

! close file
		close(27)

! call the system to convert image to GIF (can be commented out if "call system" is missing in your compiler)
		call system(system_command)
		print *,'convert over!'

	end subroutine


!***************************************************************************************************
! eos_bahcall.f90 10/18/17
! EoS Replacement based on Bahcall ().
! This file contains routines which calculate EoS quantites needed to calculate screening
! corrections for reaction rates.
!***************************************************************************************************

Module xnet_eos
  Implicit None

Contains

  Subroutine eos_initialize
    !-----------------------------------------------------------------------------------------------
    ! This routine initializes the EoS.
    !-----------------------------------------------------------------------------------------------
    Implicit None
    Return
  End Subroutine eos_initialize

  Subroutine eos_interface(rho,t9,y,ye,cv,efermkt,defermktdt9)
    !-----------------------------------------------------------------------------------------------
    ! This routine updates the Equation of State for changes in temperature and density.
    !
    ! Bahcall introduced a fit for the plasma parameters needed to calculate the screening factors
    ! for nuclear reaction based on the easier to calculate efermkt (the ratio of the electron
    ! Fermi Energy to the themal energy) instead of the more general expresions based on etae (the
    ! ratio of the electron chemical potential to the thermal energy), which generally require a
    ! complex Equation of State to calculate.   For basic cases, XNet uses Bahcall's approach
    ! to simplify the
    !
    ! Note: the factors efermkt and defermktdt9 (the derivative of efermkt wrt to temperature) in the
    ! subroutine interface are stored in XNet's conditions module as etae and detaedt9.  For more
    ! general EoS, etae and detaedt9 are their proper selves.
    !-----------------------------------------------------------------------------------------------
    Use nuclear_data, Only: zz53
    Use xnet_constants, Only: asig, avn, bok, e2, pi, pi2, third, emass, clt, ele_en, hbar
    Use xnet_controls, Only: idiag, iheat, iscrn, lun_diag
    Use xnet_types, Only: dp
    Use xnet_abundances, Only: y_moment
    Implicit None

    ! Input variables
    Real(dp), Intent(in) :: t9, rho, y(:)

    ! Output variables
    Real(dp), Intent(out) :: ye, cv, efermkt, defermktdt9

    ! Local variables
    Real(dp), Parameter :: a1 = 0.898004, b1 = 0.96786, c1 = 0.220703, d1 = -0.86097
    Real(dp), Parameter :: a2 = -0.86602540378, b2 = 0.29561, c2 = 1.9885
    Real(dp) :: ytot, bkt, abar, zbar, z2bar, zibar, z53bar
    Real(dp) :: etae_mb, ae, gam, gam14, gam32, gamc2, rel_ef
    Real(dp) :: eion, erad, ecoul
    Real(dp) :: deiondt9, deraddt9, decouldt9

    ! Calculate Ye and other needed moments of the abundance distribution
    Call y_moment(y,ye,ytot,abar,zbar,z2bar,zibar)

    If ( iscrn > 0 .or. iheat > 0 ) Then

      bkt = bok*t9
      etae_mb = log(rho*avn*ye * (2.0*pi*hbar**2 / (emass*bkt))**1.5)
      rel_ef = hbar * (3.0*pi2*rho*avn*ye)**third / (emass*clt)
      efermkt = ele_en * (sqrt(1.0 + rel_ef**2) - 1.0) / bkt
      defermktdt9 = -efermkt/t9

      ! Calculate energy derivatives (assume etot = eion + erad + ecoul) (ignore degenerate electron energy)
      eion = 1.5*bkt*ytot
      deiondt9 = 1.5*ytot*bok

      erad = asig*bkt*bkt*bkt*bkt / (rho*avn)
      deraddt9 = 4.0*erad / t9

      ae = (3.0 / (4.0*pi*avn*rho*ye))**third ! electron-sphere radius
      z53bar = sum(zz53 * y) / ytot
      gam = z53bar*e2 / (ae*bkt) ! ionic Coulomb coupling parameter
      If ( gam >= 1.0 ) Then
        gam14 = gam**0.25
        ecoul = (a1*gam + b1*gam14 + c1/gam14 + d1) * bkt * ytot
        decouldt9 = ecoul/t9 - bok * ytot * (a1*gam + 0.25 * (b1*gam14 - c1/gam14))
      Else
        gam32 = gam*sqrt(gam)
        gamc2 = gam**c2
        ecoul = (a2*gam32 + b2*gamc2) * bkt * ytot
        decouldt9 = ecoul/t9 - bok * ytot * (1.5*a2*gam32 + b2*c2*gamc2)
      EndIf
      cv = deiondt9 + deraddt9 + decouldt9
    Else
      efermkt = 0.0
      defermktdt9 = 0.0
      cv = 0.0
    EndIf

    If ( idiag >= 3 ) Write(lun_diag,"(a,6es23.15)") 'EOS',t9,rho,ye,cv,efermkt,defermktdt9

    Return
  End Subroutine eos_interface

  Subroutine eos_screen(t9,rho,y,efermkt,defermktdt9,ztilde,zinter,lambda0,gammae,dztildedt9)
    !-----------------------------------------------------------------------------------------------
    ! This routine Bahcall's approach to calculate the factors needed for screening from the input
    ! temperature, density and composition.
    !
    ! Note: the efermkt and defermktdt9 in the subroutine interface are stored in XNet's conditions
    ! module as etae and detaedt9.  For more general EoS, etae and detaedt9 are their proper selves.
    !-----------------------------------------------------------------------------------------------
    Use xnet_constants, Only: avn, bok, clt, e2, ele_en, emass, hbar, pi, pi2, third, two3rd, &
      & thbim2, twm2bi
    Use xnet_controls, Only: idiag, iheat, lun_diag
    Use xnet_types, Only: dp
    Use xnet_abundances, Only: y_moment
    Implicit None

    ! Input variables
    Real(dp), Intent(in) :: t9, rho, y(:), efermkt, defermktdt9

    ! Output variables
    Real(dp), Intent(out) :: ztilde, zinter, lambda0, gammae, dztildedt9

    ! Local variables
    Real(dp) :: ye, ytot, bkt, abar, zbar, z2bar, zibar
    Real(dp) :: sratio, ae, dsratiodefermkt

    ! Calculate Ye and other needed moments of the abundance distribution
    Call y_moment(y,ye,ytot,abar,zbar,z2bar,zibar)

    ! Calculate ratio f'/f for electrons (Salpeter, Eq. 24)
    Call salpeter_ratio(efermkt,sratio,dsratiodefermkt)
    ztilde = sqrt(z2bar + zbar*sratio)
    If ( iheat > 0 ) Then
      dztildedt9 = 0.5*zbar/ztilde * dsratiodefermkt*defermktdt9
    Else
      dztildedt9 = 0.0
    EndIf

    ! Calculate plasma quantities
    bkt = bok*t9
    lambda0 = sqrt(4.0*pi*rho*avn*ytot) * (e2/bkt)**1.5 ! DGC, Eq. 3
    ae = (3.0 / (4.0*pi*avn*rho*ye))**third ! electron-sphere radius
    gammae = e2 / (ae*bkt) ! electron Coulomb coupling parameter
    zinter = zibar / (ztilde**thbim2 * zbar**twm2bi)
    If ( idiag >= 2 ) Write(lun_diag,"(a14,9es23.15)") 'EOS Screen', &
      & t9,rho,ye,z2bar,zbar,sratio,ztilde,ztilde*lambda0,gammae

    Return
  End Subroutine eos_screen

  Subroutine salpeter_ratio(efmkt,ratio,dratiodefmkt)
    !-----------------------------------------------------------------------------------------------
    ! This routine calculates the Salpeter (1954) ratio f'/f(eta) needed for electron screening, using
    ! a fit to Figure 24 in that paper. efmkt is the ratio of electron chemical potential to kT.
    !-----------------------------------------------------------------------------------------------
    Use xnet_constants, Only: ln_10
    Use xnet_controls, Only: iheat
    Use xnet_types, Only: dp
    Implicit None

    ! Input variables
    Real(dp), Intent(in) :: efmkt

    ! Output variables
    Real(dp), Intent(out) :: ratio, dratiodefmkt

    ! Local variables
    Real(dp), Parameter :: a0 = 1.578347, c0 = 0.75793, c1 = -0.54621
    Real(dp), Parameter ::  c2 = -0.30964,  c3 = 0.12535,  c4 = 0.1203,  c5 = -0.012857,  c6 = -0.014768
    Real(dp), Parameter :: dc2 = -0.61928, dc3 = 0.37605, dc4 = 0.4812, dc5 = -0.064285, dc6 = -0.088608
    Real(dp) :: lefmkt

    lefmkt = log10(efmkt)
    If ( lefmkt <= -a0 ) Then ! Bahcall uses limit of -2, but this gives ratio slightly above 1.
      ratio = 1.0
    ElseIf ( lefmkt >= 1.5 ) Then
      ratio = 0.0
    Else
      ratio = c0 + (c1*lefmkt) + (c2*lefmkt**2) + (c3*lefmkt**3) + (c4*lefmkt**4) + (c5*lefmkt**5) + (c6*lefmkt**6)
    Endif

    If ( iheat > 0 .and. lefmkt > a0 .and. lefmkt < 1.5 ) Then
      dratiodefmkt = c1 + dc2*lefmkt + dc3*lefmkt**2 + dc4*lefmkt**3 + dc5*lefmkt**4 + dc6*lefmkt**5
      dratiodefmkt = dratiodefmkt / (ln_10*efmkt)
    Else
      dratiodefmkt = 0.0
    EndIf

    Return
  End Subroutine salpeter_ratio

End Module xnet_eos


      subroutine setprob
      implicit double precision (a-h,o-z)
      character*12 fname
      common /cparam/ grav,x1,x2
      common /comeps/ eps
      common /ctopo/ Bocean, Bshelf, width, start
c
c     # Shallow water equations
c
c
      iunit = 7
      fname = 'setprob.data'
c     # open the unit with new routine from Clawpack 4.4 to skip over
c     # comment lines starting with #:
      call opendatafile(iunit, fname)

c     # Graviational constant g:
      grav = 9.81d0
c
c     # initial data has pulse of height eps
      read(7,*) eps

c     # topography data:
      read(7,*) Bocean
      read(7,*) Bshelf
      read(7,*) width
      read(7,*) start
      read(7,*) x1
      read(7,*) x2

      return
      end


C BOGUS DRIVER
C     VCM = covcorm(x[*][*], iopt[2]:integer)
C           NCL:   x(nvar,ntim)

C NCLFORTSTART
c     subroutine BOGUS (ntim,nvar,x,xmsg,iopt,ier)
c     implicit none
c                                              ! input
c     integer ntim, nvar, iopt(2), ier
c     double precision x(ntim,nvar), xmsg, trace
c                                              ! output
c     integer lvcm
c
c     lvcm = (nvar*(nvar+1))/2
c
c     if (iopt(1).eq.0) then
c                                              ; return sym storage mode
c         real, allocatable, dimension(:)   :: vcm
c         allocate (vcm1d(lvcm), stat=ier)
c         call dcovcormssm (ntim,nvar,x,xmsg,iopt(2)
c    +                     ,vcm1d,lvcm,trace,ier)
c         return(vcm1d)
c     else
c                                              ; return as 2D
c         real, allocatable, dimension(:,:) :: vcm
c         allocate (vcm2d(nvar,nvar), stat=ier)
c         call dcovcorm (ntim,nvar,x,xmsg, iopt(2)
c    +                  ,vcm2d, lvcm,trace,ier)
c         return(vcm2d)
c     end if

c     return
c     end

C NCLFORTSTART
      subroutine dcovcormssm (ntim,nvar,x,xmsg,iopt
     +                       ,vcm,lvcm,trace,ier)

c This is a driver routine to a suite of subroutines that
c     will calculate covariance or correlation matrices
c     x        - input data array  ( unchanged on output)
c     ntim,nvar- exact dimensions of x in calling routine
c     xmsg     - missing data code (if none set to some no. not encountered)
c     iopt     - 0 ==> covariance, 1 ==> correlation
c     vcm      - var-cov matrix
c     trace    - sum of diagonal elements
c                                              ! input
      integer ntim, nvar, iopt, lvcm, ier
      double precision x(ntim,nvar), xmsg, trace
c                                              ! output
      double precision vcm(lvcm)
C NCLEND

      ier   = 0
c
c iopt == 0 --> calculate variance-covariance matrix
c iopt == 1 --> calculate correlation matrix
c
      if (iopt.eq.0) then
          call dvcmssm (x,ntim,nvar,ntim,nvar,xmsg,vcm,lvcm,ier)
          nn    = 0
          trace = 0.0d0
          do nv=1,nvar
             nn    = nn + nv
             trace = trace + vcm(nn)
          end do
      else
          call dcrmssm (x,ntim,nvar,ntim,nvar,xmsg,vcm,lvcm,ier)
          trace = nvar
      end if

      return
      end

C NCLFORTSTART
      subroutine dcovcorm (ntim,nvar,x,xmsg, iopt, vcm, lvcm, trace,ier)
c
c This is a driver routine to a suite of subroutines that
c     will calculate covariance or correlation matrices

c     x        - input data array  ( unchanged on output)
c     ntim,nvar- exact dimensions of x in calling routine
c     xmsg     - missing data code (if none set to some no. not encountered)
c     iopt     - 0 ==> covariance, 1 ==> correlation
c     vcm      - var-cov matrix
c     lvcm     - not used
c                                              ! input
      integer ntim, nvar, iopt,lvcm, ier
      double precision x(ntim,nvar), xmsg, trace
c                                              ! output
      double precision vcm(nvar,nvar)
C NCLEND
      ier = 0
c
c iopt == 1 --> calculate variance-covariance matrix
c iopt == 0 --> calculate correlation matrix
c
      if (iopt.eq.0) then
          call dvcvmns (x,ntim,nvar,ntim,nvar,xmsg,vcm,lvcm,ier)
          trace = 0.0d0
          do nv=1,nvar
             trace = trace + vcm(nv,nv)
          end do
      else
          call dcormns (x,ntim,nvar,ntim,nvar,xmsg,vcm,lvcm,ier)
          trace = nvar
      end if

      return
      end


      PROGRAM WFNPLOT
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER AT*6,TT*6,EL1*3,EL*3,NEW*3,INPUT*24,OUTPUT*24,  &
          ATOM*6,TERM*6,XA*3,OUTPUT2*24,leg*50,                &
          format_string*50,name*100
      DIMENSION P(220,30),EL(30),R(220),R2(220)
!
      write(*,*) '****************************************************'
      write(*,*) 'Program wfnplot writes HF/MCHF radial wave functions'
      write(*,*) 'to following output files:'
      write(*,*)
      write(*,*) 'Matlab/GNU Octave file "octave_name.m"'
      write(*,*) 'Xmgrace file "xmgrace_name.agr"'
      write(*,*)
      write(*,*) 'Input file:  name.w'
      write(*,*)
      write(*,*) 'To plot orbital: press enter'
      write(*,*) 'To remove orbital: type "d" or "D" and press enter'
      write(*,*)
      write(*,*) '                             Jorgen Ekman Jun 2015'
      write(*,*) '****************************************************'

      inc = 1

      WRITE(*,*) 'Name of state:'
      READ(*,*) name
      OPEN(3,FILE=trim(name)//'.w',STATUS='OLD',FORM='UNFORMATTED')
      OPEN(4,FILE='octave_'//trim(name)//'.m',STATUS='UNKNOWN')
      OPEN(8,FILE='xmgrace_'//trim(name)//'.agr',STATUS='UNKNOWN')
      write(*,*)
      write(*,*) 'To have r on x-axis: type "y" otherwise "n" for sqrt(r '
      write(*,*)
      read(*,*) XA

      IUF=3
      nwf=1
      MM = 0
2     P(1,nwf) = 0.D0
      READ(IUF,END=5) AT,TT,EL1,M,ZT,ETI,EKI,AZI,(P(J,NWF),J=2,M+1)
      WRITE(6,'(2x,A,A,$)') EL1,' = '
      READ(5,'(A)') NEW
      IF ( NEW .NE. 'd  ' .AND. NEW .NE. 'D  ' ) THEN
         IF ( NEW .NE. '   ') THEN
            EL1 = NEW
         ENDIF
         EL(NWF) = EL1
	 NWF = NWF + 1
         Z = ZT
	 ATOM = AT
	 TERM = TT
	 MM = MAX(M,MM)
      END IF
      GO TO 2
5     CLOSE(UNIT=3)
      RHO = -4.0
      H = 1/16.
      R(1) = 0.d0
      R2(1) = 0.d0
      DO 10 J = 2,220
         R(J) = EXP(RHO)/Z
         R2(J) = SQRT(R(J))
	 RHO = RHO + H
10    CONTINUE
!
!	LIST TABLES OF RADIAL FUNCTIONS
!
      NWF = NWF -1
      write(4,*) '% sqrt(r)    P(nl;r)'
      write(4,*) 'clf'

      if(XA.eq.'y  ') then
         write(8,*) '@    xaxis  label "r"'
      else
         write(8,*) '@    xaxis  label "sqrt(r)"'
      end if
      write(8,*) '@    yaxis  label "P(r)"'
      write(8,*) '# sqrt(r)    P(nl;r)'

      DO 20 I = 1,NWF

         if(I-1.lt.10) then
            format_string = "(A,I1,3A)"
         else
            format_string = "(A,I2,3A)"
         end if
         write (leg,format_string)  &
             '@    s',I-1,'  legend  "',EL(I),'"'
         write(8,*) trim(leg)
         write(8,*) '# ',EL(I)

	 write(4,*) 'P = ['
	 DO 21 J = 1,MM,inc
	    Pwave = P(J,I)*R2(J)
            IF(XA.EQ.'y  ') THEN
               IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1) 	&
                   WRITE(4,'(F10.4,F12.3)') R(J),Pwave
               WRITE(8,'(F10.4,F12.3)') R(J),Pwave
            ELSE
               IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1) 	&
                   WRITE(4,'(F10.4,F12.3)') R2(J),Pwave
               WRITE(8,'(F10.4,F12.3)') R2(J),Pwave
            END IF
 21      CONTINUE
         write(8,*)
	 write(4,*) '];'
         write(4,*) 'plot(P(:,1), P(:,2))'
         write(4,*) 'hold all'
 20   CONTINUE
      IF(XA.EQ.'y  ') THEN
         write(4,*) 'xlabel (''r'', ''fontsize'', 12)'
      ELSE
         write(4,*) 'xlabel (''sqrt(r)'', ''fontsize'', 12)'
      END IF
      write(4,*) 'ylabel (''P(r)'', ''fontsize'', 12)'
      write(4,*) 'grid on'
      write(4,101,advance='no') 'legend('
      DO 22 I = 1,NWF
         IF(I.LT.NWF) THEN
            write(4,102,advance='no') '''',EL(I),''','
         ELSE
            write(4,102,advance='no') '''',EL(I),''')'
         END IF
 22   CONTINUE
 101  format(a)
 102  format(3a)
      END


      PROGRAM xbessi0
C     driver for routine bessi0
      INTEGER i,nval
      REAL bessi0,value,x
      CHARACTER text*27
      open(7,file='FNCVAL.DAT',status='OLD')
10    read(7,'(a)') text
      if (text.ne.'Modified Bessel Function I0') goto 10
      read(7,*) nval
      write(*,*) text
      write(*,'(1x,t5,a,t13,a,t28,a)')
     *     'X','Actual','BESSI0(X)'
      do 11 i=1,nval
        read(7,*) x,value
        write(*,'(f6.2,2e16.7)') x,value,bessi0(x)
11    continue
      close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xbessi0.for


*DECK DHKSEQ
      SUBROUTINE DHKSEQ (X, M, H, IERR)
C***BEGIN PROLOGUE  DHKSEQ
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBSKIN
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (HKSEQ-S, DHKSEQ-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C   DHKSEQ is an adaptation of subroutine DPSIFN described in the
C   reference below.  DHKSEQ generates the sequence
C   H(K,X) = (-X)**(K+1)*(PSI(K,X) PSI(K,X+0.5))/GAMMA(K+1), for
C            K=0,...,M.
C
C***SEE ALSO  DBSKIN
C***REFERENCES  D. E. Amos, A portable Fortran subroutine for
C                 derivatives of the Psi function, Algorithm 610, ACM
C                 Transactions on Mathematical Software 9, 4 (1983),
C                 pp. 494-502.
C***ROUTINES CALLED  D1MACH, I1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  DHKSEQ
      INTEGER I, IERR, J, K, M, MX, NX
      INTEGER I1MACH
      DOUBLE PRECISION B, FK, FLN, FN, FNP, H, HRX, RLN, RXSQ, R1M5, S,
     * SLOPE, T, TK, TRM, TRMH, TRMR, TST, U, V, WDTOL, X, XDMY, XH,
     * XINC, XM, XMIN, YINT
      DOUBLE PRECISION D1MACH
      DIMENSION B(22), TRM(22), TRMR(25), TRMH(25), U(25), V(25), H(*)
      SAVE B
C-----------------------------------------------------------------------
C             SCALED BERNOULLI NUMBERS 2.0*B(2K)*(1-2**(-2K))
C-----------------------------------------------------------------------
      DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10),
     * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19),
     * B(20), B(21), B(22) /1.00000000000000000D+00,
     * -5.00000000000000000D-01,2.50000000000000000D-01,
     * -6.25000000000000000D-02,4.68750000000000000D-02,
     * -6.64062500000000000D-02,1.51367187500000000D-01,
     * -5.06103515625000000D-01,2.33319091796875000D+00,
     * -1.41840972900390625D+01,1.09941936492919922D+02,
     * -1.05824747562408447D+03,1.23842434241771698D+04,
     * -1.73160495905935764D+05,2.85103429084961116D+06,
     * -5.45964619322445132D+07,1.20316174668075304D+09,
     * -3.02326315271452307D+10,8.59229286072319606D+11,
     * -2.74233104097776039D+13,9.76664637943633248D+14,
     * -3.85931586838450360D+16/
C
C***FIRST EXECUTABLE STATEMENT  DHKSEQ
      IERR=0
      WDTOL = MAX(D1MACH(4),1.0D-18)
      FN = M - 1
      FNP = FN + 1.0D0
C-----------------------------------------------------------------------
C     COMPUTE XMIN
C-----------------------------------------------------------------------
      R1M5 = D1MACH(5)
      RLN = R1M5*I1MACH(14)
      RLN = MIN(RLN,18.06D0)
      FLN = MAX(RLN,3.0D0) - 3.0D0
      YINT = 3.50D0 + 0.40D0*FLN
      SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0)
      XM = YINT + SLOPE*FN
      MX = INT(XM) + 1
      XMIN = MX
C-----------------------------------------------------------------------
C     GENERATE H(M-1,XDMY)*XDMY**(M) BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      XDMY = X
      XINC = 0.0D0
      IF (X.GE.XMIN) GO TO 10
      NX = INT(X)
      XINC = XMIN - NX
      XDMY = X + XINC
   10 CONTINUE
      RXSQ = 1.0D0/(XDMY*XDMY)
      HRX = 0.5D0/XDMY
      TST = 0.5D0*WDTOL
      T = FNP*HRX
C-----------------------------------------------------------------------
C     INITIALIZE COEFFICIENT ARRAY
C-----------------------------------------------------------------------
      S = T*B(3)
      IF (ABS(S).LT.TST) GO TO 30
      TK = 2.0D0
      DO 20 K=4,22
        T = T*((TK+FN+1.0D0)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ
        TRM(K) = T*B(K)
        IF (ABS(TRM(K)).LT.TST) GO TO 30
        S = S + TRM(K)
        TK = TK + 2.0D0
   20 CONTINUE
      GO TO 110
   30 CONTINUE
      H(M) = S + 0.5D0
      IF (M.EQ.1) GO TO 70
C-----------------------------------------------------------------------
C     GENERATE LOWER DERIVATIVES, I.LT.M-1
C-----------------------------------------------------------------------
      DO 60 I=2,M
        FNP = FN
        FN = FN - 1.0D0
        S = FNP*HRX*B(3)
        IF (ABS(S).LT.TST) GO TO 50
        FK = FNP + 3.0D0
        DO 40 K=4,22
          TRM(K) = TRM(K)*FNP/FK
          IF (ABS(TRM(K)).LT.TST) GO TO 50
          S = S + TRM(K)
          FK = FK + 2.0D0
   40   CONTINUE
        GO TO 110
   50   CONTINUE
        MX = M - I + 1
        H(MX) = S + 0.5D0
   60 CONTINUE
   70 CONTINUE
      IF (XINC.EQ.0.0D0) RETURN
C-----------------------------------------------------------------------
C     RECUR BACKWARD FROM XDMY TO X
C-----------------------------------------------------------------------
      XH = X + 0.5D0
      S = 0.0D0
      NX = INT(XINC)
      DO 80 I=1,NX
        TRMR(I) = X/(X+NX-I)
        U(I) = TRMR(I)
        TRMH(I) = X/(XH+NX-I)
        V(I) = TRMH(I)
        S = S + U(I) - V(I)
   80 CONTINUE
      MX = NX + 1
      TRMR(MX) = X/XDMY
      U(MX) = TRMR(MX)
      H(1) = H(1)*TRMR(MX) + S
      IF (M.EQ.1) RETURN
      DO 100 J=2,M
        S = 0.0D0
        DO 90 I=1,NX
          TRMR(I) = TRMR(I)*U(I)
          TRMH(I) = TRMH(I)*V(I)
          S = S + TRMR(I) - TRMH(I)
   90   CONTINUE
        TRMR(MX) = TRMR(MX)*U(MX)
        H(J) = H(J)*TRMR(MX) + S
  100 CONTINUE
      RETURN
  110 CONTINUE
      IERR=2
      RETURN
      END


SUBROUTINE fc2d_geoclaw_update_gauge (mx,my,mbc,meqn,xlower,ylower, &
    dx,dy,q,maux,aux,xc,yc,qvar,avar)

    use geoclaw_module, only: dry_tolerance

    implicit none

    integer :: mx, my, mbc, meqn, maux
    real(kind=8) :: xlower, ylower, dx, dy, xc, yc
    real(kind=8) :: q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
    real(kind=8) :: aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc)
    real(kind=8) :: qvar(meqn), avar(maux)

    !! local variables:
    real(kind=8) :: xcent,ycent,xoff,yoff
    integer :: ioff,joff,iindex,jindex,mq
    real(kind=8) :: h(4),drytol2,topo

    iindex =  int((xc-xlower)/dx) + 1
    jindex =  int((yc-ylower)/dy) + 1

    xcent  = xlower + (iindex-.5d0)*dx
    ycent  = ylower + (jindex-.5d0)*dy
    xoff   = (xc-xcent)/dx
    yoff   = (yc-ycent)/dy

    drytol2 = 0.1d0 * dry_tolerance

    h(1) = q(1,iindex,jindex)
    h(2) = q(1,iindex+1,jindex)
    h(3) = q(1,iindex,jindex+1)
    h(4) = q(1,iindex+1,jindex+1)

    if ((h(1) < drytol2) .or.  &
        (h(2) < drytol2) .or.  &
        (h(3) < drytol2) .or.  &
        (h(4) < drytol2)) then
        !! One of the cells is dry, so just use value from grid cell
        !! that contains gauge rather than interpolating

        !! icell = int(1.d0 + (xc - xlower) / hx)
        !! jcell = int(1.d0 + (yc - ylower) / hy)
        do mq=1,3
            qvar(mq) = q(mq,iindex,jindex)
        enddo
        !! This is the bottom layer and we should figure out the
        !! topography
        topo = aux(1,iindex,jindex)
    else
        !! Linear interpolation between four cells
        do mq=1,3
            qvar(mq) = (1.d0 - xoff) * (1.d0 - yoff) &
                * q(mq,iindex,jindex)  &
                + xoff*(1.d0 - yoff) * q(mq,iindex+1,jindex)  &
                + (1.d0 - xoff) * yoff * q(mq,iindex,jindex+1)  &
                + xoff * yoff * q(mq,iindex+1,jindex+1)
        enddo
        topo = (1.d0 - xoff) * (1.d0 - yoff)  &
                  * aux(1,iindex,jindex)  &
                  + xoff * (1.d0 - yoff) * aux(1,iindex+1,jindex)  &
                  + (1.d0 - xoff) * yoff * aux(1,iindex,jindex+1)  &
                  + xoff * yoff * aux(1,iindex+1,jindex+1)
    endif

    ! Extract surfaces
    !!eta = qvar(1) + topo  !! Compute this when printing buffers
    avar(1) = topo

    ! Zero out tiny values to prevent later problems reading data,
    ! as done in valout.f
    do mq = 1,3
        if (abs(qvar(mq)) < 1d-99) qvar(mq) = 0.d0
    end do
    !! if (abs(eta) < 1d-99) eta = 0.d0

END SUBROUTINE fc2d_geoclaw_update_gauge


!==========================================================================
elemental function gsw_sr_from_sp (sp)
!==========================================================================
!
! Calculates Reference Salinity, SR, from Practical Salinity, SP.
!
! sp     : Practical Salinity                              [unitless]
!
! gsw_sr_from_sp : Reference Salinity                      [g/kg]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_ups

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sp

real (r8) :: gsw_sr_from_sp

gsw_sr_from_sp = sp*gsw_ups

return
end function

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