subroutine ao_i(nlon_i , nlat_i , numlon_i, lon_i , lat_i , &
                nlon_o , nlat_o , numlon_o, lon_o , lat_o , &
                mx_ovr , i_ovr  , j_ovr   , w_ovr , re    , &
                area_o , relerr )

  use shr_kind_mod, only: r8 => shr_kind_r8

! -----------------------------------------------------------------
  implicit none
! ------------------------ code history ---------------------------
! source file:       ao_i.F
! purpose:           area averaging initialization: indices and weights
! date last revised: November 1996
! author:            Gordon Bonan
! standardized:
! reviewed:
! -----------------------------------------------------------------

! ------------------------ notes ----------------------------------
! get indices and weights for area-averaging between input and output grids

! o input grid does not have to be finer resolution than output grid

! o both grids must be oriented south to north, i.e., cell(lat+1)
!   must be north of cell(lat). the southern edge of the first row
!   must be -90 (south pole) and the northern edge of the last row
!   must be +90 (north pole)

! o both grids must be oriented eastwards, i.e., cell(lon+1) must be
!   east of cell(lon). but the two grids do not have to start at the
!   same longitude, i.e., one grid can start at dateline and go east;
!   the other grid can start at greenwich and go east. longitudes for
!   the western edge of the cells must increase continuously and span
!   360 degrees. examples
!   dateline            :  -180 to 180         (- longitudes west of greenwich)
!   greenwich           :     0 to 360
!   greenwich (centered): -dx/2 to -dx/2 + 360 (- longitudes west of greenwich)

! for each output grid cell
! o number of input grid cells that overlap with output grid cell (n_ovr)
! o longitude index (1 <= i_ovr <= nlon_i) of the overlapping input grid cell
! o latitude index  (1 <= j_ovr <= nlat_i) of the overlapping input grid cell

! for field values fld_i on an  input grid with dimensions nlon_i and nlat_i
!     field values fld_o on an output grid with dimensions nlon_o and nlat_o are
! fld_o(io,jo) =
! fld_i(i_ovr(io,jo,     1),j_ovr(io,jo,     1)) * w_ovr(io,jo,     1) +
!                             ... + ... +
! fld_i(i_ovr(io,jo,mx_ovr),j_ovr(io,jo,mx_ovr)) * w_ovr(io,jo,mx_ovr)

! error check: overlap weights of input cells sum to 1 for each output cell
! -----------------------------------------------------------------

! ------------------- input variables -----------------------------
  integer nlon_i              !input grid max number of input longitude points
  integer nlat_i              !input grid number of input  latitude points
  integer numlon_i(nlat_i)    !input grid number of lon points for each lat
  integer nlon_o              !output grid max number of output lon points
  integer nlat_o              !output grid number of output latitude points
  integer numlon_o(nlat_o)    !output grid number of lon points for each lat
  integer mx_ovr              !max num of input cells that overlap output cell

  real(r8) lon_i(nlon_i+1,nlat_i) !input  grid cell lon, western edge  (degrees)
  real(r8) lon_o(nlon_o+1,nlat_o) !output grid cell lon, western edge  (degrees)
  real(r8) lat_i(nlat_i+1)        !input  grid cell lat,  southern edge (degrees)
  real(r8) lat_o(nlat_o+1)        !output grid cell lat,  southern edge (degrees)
  real(r8) area_o(nlon_o,nlat_o)  !cell area on output grid
  real(r8) re                     !radius of earth
  real(r8) relerr                 !max error: sum overlap weights ne 1
! -----------------------------------------------------------------

! ------------------- output variables ----------------------------
  integer i_ovr(nlon_o,nlat_o,mx_ovr)  !lon index, overlapping input cell
  integer j_ovr(nlon_o,nlat_o,mx_ovr)  !lat index, overlapping input cell
  real(r8)  w_ovr(nlon_o,nlat_o,mx_ovr)  !overlap weights for input cells
! -----------------------------------------------------------------

! ------------------- local variables -----------------------------
  integer io,ii        !input and output grids longitude loop index
  integer jo,ji        !input and output grids latitude  loop index
  integer n            !overlapping cell index

  real(r8) offset          !used to shift x-grid 360 degrees
  real(r8) f_ovr           !sum of overlap weights for cells on output grid
!
! Dynamic
!
  integer n_ovr(nlon_o,nlat_o) !number of overlapping input cells

! -----------------------------------------------------------------
! initialize overlap weights on output grid to zero for maximum
! number of overlapping points. set lat and lon indices of overlapping
! input cells to dummy values. set number of overlapping cells to zero
! -----------------------------------------------------------------

  do n = 1, mx_ovr
    do jo = 1, nlat_o
      do io = 1, numlon_o(jo)
        i_ovr(io,jo,n) = 1
        j_ovr(io,jo,n) = 1
        w_ovr(io,jo,n) = 0.
      end do
    end do
  end do

  do jo = 1, nlat_o
    do io = 1, numlon_o(jo)
      n_ovr(io,jo) = 0
    end do
  end do

! -----------------------------------------------------------------
! first pass to find cells that overlap, area of overlap, and weights
! -----------------------------------------------------------------

  call ao (nlon_i , nlat_i , numlon_i, lon_i  , lat_i  , &
           nlon_o , nlat_o , numlon_o, lon_o  , lat_o  , &
           area_o , re     , mx_ovr  , n_ovr  , i_ovr  , &
           j_ovr  , w_ovr  )

! -----------------------------------------------------------------
! second pass to find cells that overlap, area of overlap, and weights
! -----------------------------------------------------------------

! shift x-grid to locate periodic grid intersections
! the following assumes that all lon_i(1,:) have the same value
! independent of latitude and that the same holds for lon_o(1,:)

  if (lon_i(1,1) .lt. lon_o(1,1)) then
    offset = 360.0
  else
    offset = -360.0
  end if

  do ji = 1,nlat_i
    do ii = 1, numlon_i(ji) + 1
      lon_i(ii,ji) = lon_i(ii,ji) + offset
    end do
  end do

! find overlap

  call ao (nlon_i , nlat_i , numlon_i , lon_i , lat_i  , &
           nlon_o , nlat_o , numlon_o , lon_o , lat_o  , &
           area_o , re     , mx_ovr   , n_ovr , i_ovr  , &
           j_ovr  , w_ovr  )

! restore x-grid (un-shift x-grid)

  do ji = 1,nlat_i
    do ii = 1, numlon_i(ji) + 1
      lon_i(ii,ji) = lon_i(ii,ji) - offset
    end do
  end do

! -----------------------------------------------------------------
! error check: overlap weights for input grid cells must sum to 1
! -----------------------------------------------------------------

  do jo = 1, nlat_o
    do io = 1, numlon_o(jo)
      f_ovr = 0.

      do n = 1, mx_ovr
        f_ovr = f_ovr + w_ovr(io,jo,n)
      end do

      if (abs(f_ovr-1.) .gt. relerr) then
        write (6,*) 'AO_I error: area not conserved for',' lon,lat = ', io,jo
        write (6,'(a30,e20.10)') '   sum of overlap weights = ', f_ovr
        call endrun
      end if

    end do
  end do

  return
end subroutine ao_i


!=============================================================================!
        program mkvortex
!
!  Generate an initial condition with one or more Oseen type vortices
!
!  Written:  11-15-99
!
!  Updated:  03-14-01
!=============================================================================!
        use const
        implicit none

!.... flow variables

        integer :: nx, ny, nz=1, ndof=5, ier
        real    :: Re, Ma, Pr, gamma=1.4, cv=716.5
        real    :: time=0.0
        integer :: lstep=0

        real, allocatable :: v(:,:,:)
        !$sgi distribute v(*,*,block)

!.... mesh

        real, allocatable :: x(:,:), y(:,:)
        !$sgi distribute x(*,block), y(*,block)
        real :: tmp

        integer i, j, k
        character*80 line
        character*1 ans
        logical :: conservative = .false.

!.... variables for the Oseen Vortex

        real :: xi, x0, y0, r, alpha = 1.2564312086261696770
        real :: rho, t, p, v_theta, v_r, theta, fact
        real :: x0_1, x0_2, y0_1, y0_2, amp_1, amp_2, amp

        real, external :: f
!=============================================================================!
        write(*,"(/,'MkVortex',/)")
        write(*,*) 'WARNING:  Indices are I,J'
        write(*,"('(P)rimitive or (C)onservative ==> ',$)")
        read (*,*) ans
        if (ans.eq.'c' .or. ans.eq.'C') conservative = .true.
        write(*,"('Enter Re, Ma, Pr ==> ',$)")
        read (*,*) Re, Ma, Pr
        write(*,"('Enter amp, x0, y0 for first vortex ==> ',$)")
        read (*,*) amp_1, x0_1, y0_1
        write(*,"('Enter amp, x0, y0 for second vortex ==> ',$)")
        read (*,*) amp_2, x0_2, y0_2

!.... read in the grid file

        open(unit=10,file='grid.dat',form='unformatted',status='old',err=100)
        read(10) nx, ny, nz
        allocate( x(nx,ny), y(nx,ny) )
        read(10) (((x(i,j), i = 1, nx), j = 1, ny), k = 1, nz), &
                 (((y(i,j), i = 1, nx), j = 1, ny), k = 1, nz), &
                 (((   tmp, i = 1, nx), j = 1, ny), k = 1, nz)
        close(10)

!.... allocate the storage area for the field

        allocate (v(ndof,nx,ny), STAT=ier)
        if (ier .ne. 0) call error('MkVortex$','Insufficient Memory for v$')

        !$omp parallel do private(i)
        do j = 1, ny
          do i = 1, ny
            v(:,i,j) = zero
          end do
        end do

!.... First Oseen vortex

        x0 = x0_1
        y0 = y0_1
        amp = amp_1

        fact = one / (gamma * Ma**2)
        xi = one - exp( -alpha )

        if (amp.ne.zero) then

        !$omp parallel do private(i,r,theta,v_theta,v_r, p, &
        !$omp&                     rho, t )
        do j = 1, ny
          do i = 1, nx
            r = sqrt( (x(i,j)-x0)**2 + (y(i,j)-y0)**2 )
            theta = atan2( y(i,j)-y0 , x(i,j)-x0 )

            if (r.eq.0) then
              v_theta = zero
              v_r = zero
              p = fact
            else
              v_theta = amp * ( one - exp( -alpha * r**2 ) ) / ( r * xi )
              v_r = zero
              p = fact * ( one - (gamma-one) * Ma**2 / &
                  (xi*r)**2 * f(alpha * r**2 ) )**(gamma/(gamma-one))
            end if

            rho = ( p / fact ) ** (-gamma)

            t = p / ( fact * rho )

            v(1,i,j) = rho
            v(2,i,j) = cos(theta) * v_r - sin(theta) * v_theta
            v(3,i,j) = sin(theta) * v_r + cos(theta) * v_theta
            v(4,i,j) = zero
            v(5,i,j) = t

          end do
        end do

        end if

        x0 = x0_2
        y0 = y0_2
        amp =  amp_2

        if (amp.ne.zero) then

        !$omp parallel do private(i,r,theta,v_theta,v_r,p, &
        !$omp&                     rho, t )
        do j = 1, ny
          do i = 1, nx
            r = sqrt( (x(i,j)-x0)**2 + (y(i,j)-y0)**2 )
            theta = atan2( y(i,j)-y0 , x(i,j)-x0 )

            if (r.eq.0) then
              v_theta = zero
              v_r = zero
              p = fact
            else
              v_theta = amp * ( one - exp( -alpha* r**2 ) ) / ( r * xi )
              v_r = zero
              p = fact * ( one - (gamma-one) * Ma**2 / &
                  (xi*r)**2 * f(alpha * r**2 ) )**(gamma/(gamma-one))
            end if

            rho = ( p / fact ) ** (-gamma)

            t = p / ( fact * rho )

            v(1,i,j) = v(1,i,j) + rho
            v(2,i,j) = v(2,i,j) + cos(theta) * v_r - sin(theta) * v_theta
            v(3,i,j) = v(3,i,j) + sin(theta) * v_r + cos(theta) * v_theta
            v(4,i,j) = zero
            v(5,i,j) = v(5,i,j) + t

          end do
        end do

        end if

!.... convert to conservative variables if needed

        if (conservative) then
          fact = one / (gamma * Ma**2)
          do j = 1, ny
            do i = 1, nx
              v(5,i,j) = fact * v(1,i,j) * v(5,i,j) / (gamma-one) + &
                         pt5 * v(1,i,j) * ( v(2,i,j)**2 + v(3,i,j)**2 + &
                         v(4,i,j)**2 )
              v(2,i,j) = v(1,i,j) * v(2,i,j)
              v(3,i,j) = v(1,i,j) * v(3,i,j)
              v(4,i,j) = v(1,i,j) * v(4,i,j)
            end do
          end do
        end if

!.... write the restart file

        open(unit=10, file='output.R.0', form='unformatted', status='unknown')
        write(10,err=1000) lstep, time, nx, ny, nz, ndof, &
                           Re, Ma, Pr, gamma, cv
        write(10,err=1000) v
        close(10)

!.... write out the potential boundary values

        open(unit=10, file='top.pot')
        do i = 1, nx
          write(10,*,err=110) v(:,i,ny)
        end do
        close(10)

        open(unit=10, file='bottom.pot')
        do i = 1, nx
          write(10,*,err=110) v(:,i,1)
        end do
        close(10)

        open(unit=10, file='left.pot')
        do j = 1, ny
          write(10,*,err=110) v(:,1,j)
        end do
        close(10)

        open(unit=10, file='right.pot')
        do j = 1, ny
          write(10,*,err=120) v(:,nx,j)
        end do
        close(10)

        stop

100     call error('MkVortex$','Reading grid.dat file$')
110     call error('MkVortex$','Writing left.pot file$')
120     call error('MkVortex$','Writing right.pot file$')
1000    call error('MkVortex$','Writing restart file$')

        end

!=============================================================================!
        real function f(x)
!
!=============================================================================!
        implicit none

        real*8, external :: dEi
        real :: x

        if (x.gt.sqrt(200.0)) then
          f = 0.5
        else
          f = 0.5 - exp(-x) + 0.5*exp(-2.0*x) + x * dEi(-2.0*x) - x * dEi(-x)
        end if

        return
        end function f

!=============================================================================!
        subroutine error(name,msg)
!
!       Generic error handler
!
!=============================================================================!
        implicit none

        integer loc
        character(*) name, msg

        loc = index(name,'$')-1
        write(*,"(/,'=====================================================')")
        write(*,"('Error in --> ',a)") name(1:loc)
        loc = index(msg,'$')-1
        write(*,"('-----------> ',a)") msg(1:loc)
        write(*,"('=====================================================',/)")

        call exit(1)

        stop
        end


SUBROUTINE DVBES1(FJ,DJ,SM,RI,NT)
  IMPLICIT NONE
  !        Arguments
  INTEGER, intent(in) :: NT
  REAL*8, intent(in)  :: RI, SM, FJ(NT)
  REAL*8, intent(out) :: DJ(NT)
  !..................................................................
  !   calculate the derivatives of the Bessel functions
  !      DJ = DFJ/DX where X = SM*RI
  !                                        D.D.KOELLING
  !..................................................................
  !   Local Parameters
  REAL*8, PARAMETER :: ZUP = 1.0D-5
  !        Local Scalars
  INTEGER            L, LM
  DOUBLE PRECISION   Q2, Q3, X
  !
  X = SM*RI
  IF (X .GT. ZUP) THEN
     Q2 = -1.d0/X
     Q3 = Q2
     DJ(1) = -FJ(2)
     LM = 1
     DO L = 2, NT
        Q3 = Q3 + Q2
        DJ(L) = FJ(LM) + Q3*FJ(L)
        LM = LM + 1
     ENDDO
  ELSE
     DJ(1) = 0.d0
     DJ(2) = 1.0D+0/3.0D+0
     DO L = 3, NT
        DJ(L) = 0.d0
     ENDDO
  ENDIF
  !
  RETURN
END SUBROUTINE DVBES1


 SUBROUTINE waterb_ini (numfl,ndime,flparm,headf)
 !Reads follower loads
 USE loa_db,ONLY: foll_seg, flpar
 USE npo_db,ONLY: coora
 IMPLICIT NONE

   !--- Dummy variables
   INTEGER(kind=4):: numfl, ndime
   TYPE(flpar):: flparm
   TYPE(foll_seg),POINTER:: headf
   !--- Local variables
   REAL (kind=8), PARAMETER  :: pi=3.141592653589793
   INTEGER(kind=4):: nn
   REAL(kind=8):: vol,x0,y0,xc,h,xl,xr,x(3,3),rr
   REAL (kind=8) l1(3),l2(3),t1(3),t3(3),area2
   TYPE(foll_seg),POINTER:: seg
   LOGICAL :: full,axisy

     axisy = flparm%nodcen == 3     !flag
     y0    = flparm%press            !water surface coordinate
     x0    = flparm%timini           !x-coordinate for volume computation
     vol = 0d0             !Initializes volume
     rr = 1d0              !Initializes radius
     IF( flparm%nodcen > 10 ) THEN
       xr=-1e9
       full = .TRUE.
     ELSE
       xl = 0d0
       xr = 0d0  !initializes coordinates for free surfaces
       full = .FALSE.
     END IF
     seg => headf
     DO nn=1,numfl

       IF (ndime == 3) THEN
         x(1,1:3) = coora(1,seg%lnofl(1:3)) - x0 !distance to reference line
         x(2,1:3) = y0 - coora(2,seg%lnofl(1:3)) !depth at nodes
         !*** evaluate the first two side vectors
         l1 = coora(:,seg%lnofl(1)) - coora(:,seg%lnofl(2))                             !side 1
         l2 = coora(:,seg%lnofl(3)) - coora(:,seg%lnofl(1))                             !side 2
         !*** evaluate the cross product => plane normal
         CALL vecpro(l1,l2,t3)                             !normal * area2  !plano yz
         CALL vecuni(3,t3,area2)                           !computes twice area
         t1 = (/-1d0,0d0,0d0/)
         area2 = area2*DOT_PRODUCT(t3,t1)
       ELSE
         x(1,1:2) = coora(1,seg%lnofl(1:2)) - x0 !distance to reference line
         x(2,1:2) = y0 - coora(2,seg%lnofl(1:2)) !depth at nodes
         IF( axisy ) rr = pi*(x(1,1)+x(1,2))     !2 Pi * r
       END IF

       IF( full )THEN
         IF(ndime == 3) THEN
           xl = -MINVAL(x(2,1:3))   !highest point
           IF( xl > xr ) xr = xl   !update
           vol = vol+((x(1,1)+x(1,2)+x(1,3))/3d0)*area2/2d0
           seg%fload = (x(2,1)+x(2,2)+x(2,3))/3d0         !depth at centroid
         ELSE
           xl = -MINVAL(x(2,1:2))   !highest point
           IF( xl > xr ) xr = xl   !update
           vol = vol+((x(1,1)+x(1,2))/2d0)*(x(2,2)-x(2,1))*rr
           seg%fload = (x(2,1)+x(2,2))/2d0         !depth at centroid
         END IF
       ELSE
         IF(ndime == 3) THEN   !only for triangular element
            !IF( x(2,1) >= 0d0 .AND. x(2,2)>= 0d0 .AND. x(2,3) >= 0d0 )THEN    !all sumerged
            vol = vol+((x(1,1)+x(1,2)+x(1,3))/3d0)*area2/2d0
            seg%fload = (x(2,1)+x(2,2)+x(2,3))/3d0   !depth at centroid
         ELSE
            IF( x(2,1) >= 0d0 .AND. x(2,2) >= 0d0 )THEN    !both sumerged
            vol = vol+((x(1,1)+x(1,2))/2d0)*(x(2,2)-x(2,1))*rr
            seg%fload = (x(2,1)+x(2,2))/2d0         !depth at centroid

           ELSE IF( x(2,1) > 0d0 .OR. x(2,2) > 0d0 )THEN !if one node is below line
            h  = x(2,1)/(x(2,1) - x(2,2))           !normalized position from node 1 (+)
            xc = (1d0-h)*x(1,1) + h*x(1,2)          !x-intersection with free surface
             IF( x(2,2) > 0 )THEN                    !node 1 is above line
              IF( axisy ) rr = pi*(xc+x(1,2))       !2 Pi * r
              vol = vol+(xc    +x(1,2))/2d0*x(2,2)*rr
              seg%fload = x(2,2)*(1d0-h)/2d0        !equivalent pressure at centroid
              IF( xc > xr ) xr = xc
             ELSE                                    !node 2 is above line
              IF( axisy ) rr = pi*(x(1,1)+xc )      !2 Pi * r
              vol = vol-(x(1,1)+xc    )/2d0*x(2,1)*rr
              seg%fload = x(2,1)*h/2d0              !equivalent pressure at centroid(-)
              IF( xc < xl ) xl = xc
             END IF
           ELSE
           seg%fload = 0d0                         !pressure at centroid
           END IF
         END IF
       END IF
       seg => seg%next
     END DO   !loop over SEGMENTS

     flparm%volin = vol
     flparm%vol   = vol
     SELECT CASE (flparm%nodcen)
     CASE  (1)
       flparm%pext  = xr           !symmetric problems
     CASE  (2)
       flparm%pext  = xr - xl      !closed bags
     CASE  (3)
       flparm%pext  = xr*xr*pi*2d0 !axisymmetric problems
     CASE (11:)                    !update initial pressure
       IF( flparm%press == 0d0 ) THEN
         flparm%press = xr
         seg => headf
         DO nn=1,numfl
           seg%fload = seg%fload + xr !depth at centroid
           seg => seg%next
         END DO
       END IF
     END SELECT

 RETURN
 END SUBROUTINE waterb_ini


      SUBROUTINE slPLTE (DATE, ELONG, PHI, JFORM, EPOCH,
     :                       ORBINC, ANODE, PERIH, AORQ, E,
     :                       AORL, DM, RA, DEC, R, JSTAT)
*+
*     - - - - - - -
*      P L T E
*     - - - - - - -
*
*  Topocentric apparent RA,Dec of a Solar-System object whose
*  heliocentric orbital elements are known.
*
*  Given:
*     DATE     d     MJD of observation (JD - 2400000.5, Notes 1,5)
*     ELONG    d     observer's east longitude (radians, Note 2)
*     PHI      d     observer's geodetic latitude (radians, Note 2)
*     JFORM    i     choice of element set (1-3; Notes 3-6)
*     EPOCH    d     epoch of elements (TT MJD, Note 5)
*     ORBINC   d     inclination (radians)
*     ANODE    d     longitude of the ascending node (radians)
*     PERIH    d     longitude or argument of perihelion (radians)
*     AORQ     d     mean distance or perihelion distance (AU)
*     E        d     eccentricity
*     AORL     d     mean anomaly or longitude (radians, JFORM=1,2 only)
*     DM       d     daily motion (radians, JFORM=1 only )
*
*  Returned:
*     RA,DEC   d     RA, Dec (topocentric apparent, radians)
*     R        d     distance from observer (AU)
*     JSTAT    i     status:  0 = OK
*                            -1 = illegal JFORM
*                            -2 = illegal E
*                            -3 = illegal AORQ
*                            -4 = illegal DM
*                            -5 = numerical error
*
*  Called: slELUE, slPLTU
*
*  Notes:
*
*  1  DATE is the instant for which the prediction is required.  It is
*     in the TT timescale (formerly Ephemeris Time, ET) and is a
*     Modified Julian Date (JD-2400000.5).
*
*  2  The longitude and latitude allow correction for geocentric
*     parallax.  This is usually a small effect, but can become
*     important for near-Earth asteroids.  Geocentric positions can be
*     generated by appropriate use of routines slEVP (or slEPV) and
*     slPLNE.
*
*  3  The elements are with respect to the J2000 ecliptic and equinox.
*
*  4  A choice of three different element-set options is available:
*
*     Option JFORM = 1, suitable for the major planets:
*
*       EPOCH  = epoch of elements (TT MJD)
*       ORBINC = inclination i (radians)
*       ANODE  = longitude of the ascending node, big omega (radians)
*       PERIH  = longitude of perihelion, curly pi (radians)
*       AORQ   = mean distance, a (AU)
*       E      = eccentricity, e (range 0 to <1)
*       AORL   = mean longitude L (radians)
*       DM     = daily motion (radians)
*
*     Option JFORM = 2, suitable for minor planets:
*
*       EPOCH  = epoch of elements (TT MJD)
*       ORBINC = inclination i (radians)
*       ANODE  = longitude of the ascending node, big omega (radians)
*       PERIH  = argument of perihelion, little omega (radians)
*       AORQ   = mean distance, a (AU)
*       E      = eccentricity, e (range 0 to <1)
*       AORL   = mean anomaly M (radians)
*
*     Option JFORM = 3, suitable for comets:
*
*       EPOCH  = epoch of elements and perihelion (TT MJD)
*       ORBINC = inclination i (radians)
*       ANODE  = longitude of the ascending node, big omega (radians)
*       PERIH  = argument of perihelion, little omega (radians)
*       AORQ   = perihelion distance, q (AU)
*       E      = eccentricity, e (range 0 to 10)
*
*     Unused arguments (DM for JFORM=2, AORL and DM for JFORM=3) are not
*     accessed.
*
*  5  Each of the three element sets defines an unperturbed heliocentric
*     orbit.  For a given epoch of observation, the position of the body
*     in its orbit can be predicted from these elements, which are
*     called "osculating elements", using standard two-body analytical
*     solutions.  However, due to planetary perturbations, a given set
*     of osculating elements remains usable for only as long as the
*     unperturbed orbit that it describes is an adequate approximation
*     to reality.  Attached to such a set of elements is a date called
*     the "osculating epoch", at which the elements are, momentarily,
*     a perfect representation of the instantaneous position and
*     velocity of the body.
*
*     Therefore, for any given problem there are up to three different
*     epochs in play, and it is vital to distinguish clearly between
*     them:
*
*     . The epoch of observation:  the moment in time for which the
*       position of the body is to be predicted.
*
*     . The epoch defining the position of the body:  the moment in time
*       at which, in the absence of purturbations, the specified
*       position (mean longitude, mean anomaly, or perihelion) is
*       reached.
*
*     . The osculating epoch:  the moment in time at which the given
*       elements are correct.
*
*     For the major-planet and minor-planet cases it is usual to make
*     the epoch that defines the position of the body the same as the
*     epoch of osculation.  Thus, only two different epochs are
*     involved:  the epoch of the elements and the epoch of observation.
*
*     For comets, the epoch of perihelion fixes the position in the
*     orbit and in general a different epoch of osculation will be
*     chosen.  Thus, all three types of epoch are involved.
*
*     For the present routine:
*
*     . The epoch of observation is the argument DATE.
*
*     . The epoch defining the position of the body is the argument
*       EPOCH.
*
*     . The osculating epoch is not used and is assumed to be close
*       enough to the epoch of observation to deliver adequate accuracy.
*       If not, a preliminary call to slPRTL may be used to update
*       the element-set (and its associated osculating epoch) by
*       applying planetary perturbations.
*
*  6  Two important sources for orbital elements are Horizons, operated
*     by the Jet Propulsion Laboratory, Pasadena, and the Minor Planet
*     Center, operated by the Center for Astrophysics, Harvard.
*
*     The JPL Horizons elements (heliocentric, J2000 ecliptic and
*     equinox) correspond to SLALIB arguments as follows.
*
*       Major planets:
*
*         JFORM  = 1
*         EPOCH  = JDCT-2400000.5D0
*         ORBINC = IN (in radians)
*         ANODE  = OM (in radians)
*         PERIH  = OM+W (in radians)
*         AORQ   = A
*         E      = EC
*         AORL   = MA+OM+W (in radians)
*         DM     = N (in radians)
*
*         Epoch of osculation = JDCT-2400000.5D0
*
*       Minor planets:
*
*         JFORM  = 2
*         EPOCH  = JDCT-2400000.5D0
*         ORBINC = IN (in radians)
*         ANODE  = OM (in radians)
*         PERIH  = W (in radians)
*         AORQ   = A
*         E      = EC
*         AORL   = MA (in radians)
*
*         Epoch of osculation = JDCT-2400000.5D0
*
*       Comets:
*
*         JFORM  = 3
*         EPOCH  = Tp-2400000.5D0
*         ORBINC = IN (in radians)
*         ANODE  = OM (in radians)
*         PERIH  = W (in radians)
*         AORQ   = QR
*         E      = EC
*
*         Epoch of osculation = JDCT-2400000.5D0
*
*     The MPC elements correspond to SLALIB arguments as follows.
*
*       Minor planets:
*
*         JFORM  = 2
*         EPOCH  = Epoch-2400000.5D0
*         ORBINC = Incl. (in radians)
*         ANODE  = Node (in radians)
*         PERIH  = Perih. (in radians)
*         AORQ   = a
*         E      = e
*         AORL   = M (in radians)
*
*         Epoch of osculation = Epoch-2400000.5D0
*
*       Comets:
*
*         JFORM  = 3
*         EPOCH  = T-2400000.5D0
*         ORBINC = Incl. (in radians)
*         ANODE  = Node. (in radians)
*         PERIH  = Perih. (in radians)
*         AORQ   = q
*         E      = e
*
*         Epoch of osculation = Epoch-2400000.5D0
*
*  This revision:  19 June 2004
*
*  Copyright (C) 2004 P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE,ELONG,PHI
      INTEGER JFORM
      DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,
     :                 AORL,DM,RA,DEC,R
      INTEGER JSTAT

      DOUBLE PRECISION U(13)

*  Transform conventional elements to universal elements.
      CALL slELUE(DATE,
     :               JFORM,EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM,
     :               U,JSTAT)

*  If successful, make the prediction.
      IF (JSTAT.EQ.0) CALL slPLTU(DATE,ELONG,PHI,U,RA,DEC,R,JSTAT)

      END


      double complex function A51(j1,j2,j3,j4,j5,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'scale.f'
      include 'epinv.f'
      integer j1,j2,j3,j4,j5
      double complex Vcc,Fcc,Vsc,Fsc,l12,l23,L0,L1,Lsm1,A5lom
      double complex lnrat

C    -i * A5tree
      A5lom =-za(j3,j4)**2/(za(j1,j2)*za(j2,j3)*za(j4,j5))
      l12=lnrat(musq,-s(j1,j2))
      l23=lnrat(musq,-s(j2,j3))

C--leading N
      Vcc=
     . -(epinv**2+epinv*l12+0.5d0*l12**2)
     . -(epinv**2+epinv*l23+0.5d0*l23**2)
     . -2d0*(epinv+l23)-4d0

      Fcc=za(j3,j4)**2/(za(j1,j2)*za(j2,j3)*za(j4,j5))
     . *(Lsm1(-s(j1,j2),-s(j4,j5),-s(j2,j3),-s(j4,j5))
     . -2d0*za(j3,j1)*zb(j1,j5)*za(j5,j4)/za(j3,j4)
     .   *L0(-s(j2,j3),-s(j4,j5))/s(j4,j5))

      Vsc =0.5d0*(epinv+l23)+1d0
      Fsc =za(j3,j4)*za(j3,j1)*zb(j1,j5)*za(j5,j4)
     . /(za(j1,j2)*za(j2,j3)*za(j4,j5))*L0(-s(j2,j3),-s(j4,j5))/s(j4,j5)
     . +0.5d0*(za(j3,j1)*zb(j1,j5))**2*za(j4,j5)
     . /(za(j1,j2)*za(j2,j3))*L1(-s(j2,j3),-s(j4,j5))/s(j4,j5)**2

      A51=(Vcc+Vsc)*A5Lom+Fcc+Fsc

      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     cd_compressible for class 1 orifices where r/d=l/d
!
!     author: Yannick Muller
!
      subroutine pk_cdc_cl1(lqd,reynolds,p2p1,beta,kappa,cdc_cl1)
!
      implicit none
!
      real*8 lqd,reynolds,p2p1,beta,kappa,cdi_noz,cdi_r,cdi_se,
     &     y0,yg,cdc_cl1,rqd,cdqcv_noz,cdqcv_r
!
      rqd=lqd
!     cd incompresssible nozzle eq. 4a 4b
      call pk_cdi_noz(reynolds,cdi_noz)
!     cdr eq.5
      call pk_cdi_r(rqd,reynolds,beta,cdi_r)
!     cd incompressible sharp edge eq.3
      call pk_cdi_se(reynolds,beta,cdi_se)
!     y0 and yg , eq.15-17 , eq.18
      call pk_y0_yg(p2p1,beta,kappa,y0,yg)
!
      cdqcv_noz=cdi_noz/(0.0718d0*cdi_noz+0.9282d0)
      cdqcv_r=cdi_r/(0.0718d0*cdi_r+0.9282d0)
!     eq.25
      cdc_cl1=cdi_r*((cdqcv_noz-cdqcv_r)
     &     /(cdqcv_noz-cdi_se/0.971d0)
     &     *(y0/yg-1d0)+1d0)
!
      return
!
      end


      SUBROUTINE NTCALC(NX,N,X,HK,TH,UE,VE, NW,W,A)
C------------------------------------------------------------------
C     Calculates range of frequencies which span the
C     critical frequency.  Also calculates the amplitude
C     distribution for each frequency.
C
C    Input:  NX     array physical dimension
C            N      number of streamwise points i
C                    (i = N  point is assumed turbulent)
C            X (i)  streamwise coordinate array for integrating A(x)
C            HK(i)  kinematic shape parameter
C            TH(i)  momentum thickness
C            UE(i)  edge velocity
C            VE(i)  edge kinematic viscosity (in same units as UE*TH)
C            NW     number of frequencies to be set
C
C    Output: W(k)   radian frequencies in same units as UE/TH
C            A(i,k) amplitude distribution for frequency W(k)
C------------------------------------------------------------------
      REAL X(NX), HK(NX), TH(NX), UE(NX), VE(NX)
      REAL W(NW), A(NX,NW)
C
      REAL RSP,WSP,HSP,
     &       AR,
     &       AR_R, AR_W, AR_H,
     &       ARW_R,ARW_W,ARW_H ,
     &       AI,
     &       AI_R, AI_W, AI_H,
     &       AIW_R,AIW_W,AIW_H
C
      LOGICAL OK
C
C---- log(frequency) increment over range (i.e. 1.5 decades)
      DW = -1.50/FLOAT(NW-1)
C
C---- frequency and amplitude will be returned as zero if no instability
      DO 10 IW=1, NW
        W(IW) = 0.
        DO 105 I=1, N
          A(I,IW) = 0.
  105   CONTINUE
   10 CONTINUE
C
C---- search downstream for location where Rcrit is first exceeded
      DO 20 I=1, N-1
C------ local Rdelta*
        RDL = LOG10( HK(I)*TH(I)*UE(I)/VE(I) )
C
C------ approximate critical Rdelta* for local shape parameter
        HKB = 1.0 / (HK(I) - 1.0)
        RDLC = 2.23 + 1.35*HKB + 0.85*TANH(10.4*HKB - 7.07) - 0.1
C
        IF(RDL .GE. RDLC) GO TO 21
   20 CONTINUE
CCC   WRITE(*,*) 'Rcrit not exceeded'
      RETURN
C
   21 ISTART = I
C
C---- set frequency array at location where Rcrit is first exceeded
      I = ISTART
      UOT = UE(I)/TH(I)
      DO 30 IW=1, NW
        WLOG = -1.0 + DW*FLOAT(IW-1)
        W(IW) = (10.0 ** WLOG) * UOT
   30 CONTINUE
C
      DO 40 I=ISTART+1, N
        IM = I-1
C
C------ set flow variables over i-1,i interval
        UA = (UE(IM) + UE(I))*0.5
        VA = (VE(IM) + VE(I))*0.5
        TA = (TH(IM) + TH(I))*0.5
        HA = (HK(IM) + HK(I))*0.5
C
        IF(I.EQ.N) THEN
C------- last point is turbulent, so extrapolate from laminar region
C-       (turbulent H is likely to be inappropriate)
         UA = 1.5*UE(IM) - 0.5*UE(IM-1)
         VA = 1.5*VE(IM) - 0.5*VE(IM-1)
         TA = 1.5*TH(IM) - 0.5*TH(IM-1)
         HA = 1.5*HK(IM) - 0.5*HK(IM-1)
        ENDIF
C
C------ set local Rtheta, Hk
        RSP = UA*TA/VA
        HSP = HA
C
C------ limit Hk, (OSMAP routine would clip anyway)
        HSP = MIN( HSP , 19.999 )
C
C------ go over frequencies
        DO 405 IW=1, NW
C-------- set Ue/Theta-normalized frequency  WSP = w Theta/Ue
          WSP = W(IW)*TA/UA
C
C-------- calculate Theta-normalized spatial growth rate  AI = ai * Theta
          CALL OSMAP(RSP,WSP,HSP,
     &               AR,
     &               AR_R, AR_W, AR_H,
     &               ARW_R,ARW_W,ARW_H ,
     &               AI,
     &               AI_R, AI_W, AI_H,
     &               AIW_R,AIW_W,AIW_H , OK)
C
C-------- integrate growth rate to get amplitude
          DX = X(I) - X(IM)
          A(I,IW) = A(IM,IW) - AI * DX/TA
          A(I,IW) = MAX( A(I,IW) , 0.0 )
  405   CONTINUE
   40 CONTINUE
C
      RETURN
      END


Module schaefer_Mod
  ! Module for all Schaefer theory-related work

Contains

  subroutine schaefer(m, schaefer_a6, schaefer_b2, schaefer_n, schaefer_A, eps, eps_old, ndir, nshr, eps_vec_p_old, fp_old)

    use matProp_Mod
    use matrixAlgUtil_Mod
    use stress_Mod
    Use forlog_Mod

    ! Inputs only
    Type(matProps), intent(IN) :: m
    Double PRECISION, intent(IN) :: schaefer_a6    ! Schaefer Method material property
    Double PRECISION, intent(IN) :: schaefer_b2    ! Schaefer Method material property
    Double PRECISION, intent(IN) :: schaefer_n ! fitting parameters for schaefre
    Double PRECISION, intent(IN) :: schaefer_A ! fitting parameters for schaefre
    Double PRECISION, intent(IN) :: eps(ndir, ndir)  ! Total strain (green-lagrange)
    Double PRECISION, intent(IN) :: eps_old(ndir, ndir)  ! Total strain from previous iteration (green-lagrange)
    Integer, intent(IN) :: ndir ! number direct components in stress and strain count(sig11,...)
    Integer, intent(IN) :: nshr ! number of shear components count(sig12, ....)
    ! Inputs that are updated in place
    Double PRECISION, intent(INOUT) :: eps_vec_p_old(ndir + nshr)   ! previously calculated total plastic strain. Updated at final step to new old
    Double PRECISION, intent(INOUT) :: fp_old ! yield function value

    Double PRECISION :: f ! yield criterion
    ! stress components
    Double PRECISION :: S22
    Double PRECISION :: S12
    ! additional terms
    Double PRECISION :: C(ndir + nshr, ndir + nshr) ! Stiffness Matrix
    Double PRECISION :: th ! theta is a variable defined for convenenience. The term f - schaefer_b2 * S22 shows up frequently. This term helps save typing
    Double PRECISION :: S(ndir + nshr) ! vector of stress matrix S
    Double PRECISION :: dS(ndir + nshr) ! vector of incremental stress
    Double PRECISION :: dfdS(ndir + nshr) ! derivative of scalar FUNCTION with respect to S
    Double PRECISION :: dfdSdfdS(ndir + nshr, ndir + nshr) ! outer product of dfdS
    Double PRECISION:: dS22ddEp(ndir + nshr) ! derivative of stress component(S22) with respect to incremental plastic strain
    Double PRECISION:: dS12ddEp(ndir + nshr) ! derivative of stress compoentn (S12) with respect to incremental plastic strain
    Double PRECISION:: dfddEp(ndir + nshr) ! derivative of yield criterion with respect to incremental plastic strain
    Double PRECISION:: eye(ndir + nshr, ndir + nshr) ! identity matrix
    Double PRECISION:: dEp(ndir + nshr) ! incremental plastic strain
    Double PRECISION:: eps_vec(ndir + nshr) ! strain matrix represented as vector (green-lagrange)
    Double PRECISION:: eps_old_vec(ndir + nshr) ! strain matrix represented as vector from previous iteration (green-lagrange)
    Double PRECISION:: dE(ndir + nshr) ! total incremental strain as vector
    Double PRECISION:: residual !! value keeps track of J0 == 0
    Double PRECISION:: dSddEp(ndir + nshr) ! derivative of stress with respect to incremntal plastic strain (dEp). Only holds ith derivative at a time (hence why its not a 6 by 6)
    Double PRECISION:: dfdSdfdSd22Ep ! Holds the values of hte ith derivative of [(dfdS)(dfdS)Transpose](2,2) with respect to dEpi
    Double PRECISION:: dfdSdfdSd24Ep! Holds the values of hte ith derivative of (dfdS)(dfdS)T24 with respect to dEpi
    Double PRECISION:: dfdSdfdSd44Ep! Holds the values of hte ith derivative of (dfdS)(dfdS)T44 with respect to dEpi
    Double PRECISION:: dfdSdfdSdEp(ndir + nshr, ndir + nshr)! Corresponds to the specific (ith derivative) and is the 6 by 6 matrix which is primarily zeros but incorporates the values of dfdSdfdSdijEp into itself
    Double PRECISION:: J1a(ndir + nshr) ! Component of J1 matrix used in newton raphson
    Double PRECISION:: J1b(ndir + nshr)! Component of J1 matrix used in newton raphson
    Double PRECISION:: J1c(ndir + nshr) ! Component of J1 matrix used in newton raphson
    Double PRECISION:: dS12 ! local variable used in ith column calc of J1 matrix. its a deriv val with respect to incremental plastic strain
    Double PRECISION:: dS22 ! local variable used in ith column calc of J1 matrix. its a deriv val with respect to incremental plastic strain
    Double PRECISION:: df! local variable used in ith column calc of J1 matrix. its a deriv val with respect to incremental plastic strain
    Double PRECISION:: schaefer_nr_tolerance ! tolerance value used to determine if convergence has occurred in newton raphson loop
    Integer :: counter_limit ! maximum number of Newton-Raphson loops before divergence is assumed
    Integer :: counter ! counter of iterations done thus far in newton raphson
    ! newton raphson equation updates dEp according to the following
    ! dEp = dEp - inv(J1) * J0
    Double PRECISION:: J0(ndir + nshr) !
    Double PRECISION:: J1(ndir + nshr, ndir + nshr)! Corresponds to the specific (ith derivative) and is the 6 by 6 matrix which is primarily zeros but incorporates the values of dfdSdfdSdijEp into itself
    Double PRECISION:: J1column(ndir + nshr)

    Double PRECISION, Parameter :: zero=0.d0, one=1.d0, two=2.d0, three=3.d0, four=4.d0, six=6.d0

    schaefer_nr_tolerance = 1e-6
    counter_limit = 10000000
    ! Build the stiffness matrix
    C = StiffFunc(ndir+nshr, m%E1, m%E2, m%E3, m%G12, m%G13, m%G23, m%v12, m%v13, m%v23, zero, zero, zero)
    eye = zero; Do I = 1,ndir+nshr; eye(I,I) = one; End Do ! Identity Matrix

    ! Assume dEp = [0] (iniitally)
    dEp = zero

    ! convert matrices to vectors (3+nshrx1)
    eps_vec = Matrix2Vec(eps, nshr)
    eps_old_vec = Matrix2Vec(eps_old, nshr)
    dE = eps_vec - eps_old_vec

    counter = 0
    DO
      counter = counter + 1
      S = Matrix2Vec(Hooke(C, Vec2Matrix(eps_vec - eps_vec_p_old - dEp), nshr), nshr);
      dS = Matrix2Vec(Hooke(C, Vec2Matrix(dE - dEp), nshr), nshr);

      ! get components of stress vector for convenience
      S22 = S(2)
      S12 = S(ndir + 1)

      ! get yield FUNCTION from components of S and fitting parameters
      f = Getf(S, schaefer_a6, schaefer_b2, ndir, nshr)

      ! get terms of f deriviates wtih respect to S
      ! Partial of f with respect to Stress
      dfdS = zero
      dfdS(2) = S22 / (f - schaefer_b2 * S22) + schaefer_b2
      dfdS(ndir + 1) = schaefer_a6 * S12 / (f - schaefer_b2 * S22)

      ! dfdf * dfdsT (outer multiply the same vector with self)
      dfdSdfdS = OuterProduct(dfdS, dfdS)

      ! calc init J0
      J0 = GetJ0(schaefer_n, schaefer_A, f, dfdSdfdS, dS, dEp, ndir, nshr)

      ! derivative of stress with respect to incremental plastic strain
      ! because S = C: (eps_vec - Eoldp - dEp) and C, eps_vec, Eoldp are constants
      ! youre left with the negative of the stiffness matrix
      dS22ddEp = -C(2, :)
      dS12ddEp = -C(ndir + 1, :)

      ! for convenience defined th (theta) to be f - schaefer_b2 * S22. This term shows up a bunch
      th = f- schaefer_b2 * S22

      ! Partial of f with respect to plastic strain.
      dfddEp = (S22 / th + schaefer_b2) * dS22ddEp + ((schaefer_a6 * S12) / th) * dS12ddEp

      ! zero out J1
      J1 = zero

      ! J1 is a (ndir + nshr) x (ndir + nshr) matrix. It is the derivative of J0 with respect to dEpi.
      ! A column "i" represents the terms corresponding to the dEpi derivative
      DO i = 1, ndir + nshr, 1
        ! fill in dSdEp
        dSddEp = zero
        dSddEp(2) = dS22ddEp(i)
        dSddEp(ndir + 1) = dS12ddEp(i)

        ! local derivatives
        dS12 = dS12ddEp(i)
        dS22 = dS22ddEp(i)
        df = dfddEp(i)

        ! get the the term corresponding to the ith partial derivative of dfdSdfdS
        ! with respeoct to Epi
        ! this derivative corresponds to the (2, 2)
        dfdSdfdSd22Ep = (schaefer_b2 + S22 / th) * ( (2 * dS22) / th + (2 * (schaefer_b2 * dS22 -df) * S22) / th**2)
        ! this derivative corresponds to the (2, 4)
        dfdSdfdSd24Ep = (schaefer_a6 * dS12/th) * (schaefer_b2 + S22/th) +&
            (schaefer_a6 * S12 / th**2) * (schaefer_b2 + S22 / th) * (schaefer_b2 * dS22 - df) +&
            (schaefer_a6 * S12 / th) * (dS22 / th + (schaefer_b2 * dS22 - df)* S22 / th**2)
        ! this derivative corresponds to the (4, 4)
        dfdSdfdSd44Ep =  (2 * schaefer_a6**2 * S12 * dS12) / th**2 +&
            (schaefer_a6**2 * (2 * schaefer_b2 * dS22 - 2 * df ) * S12**2) / th**3
        ! Fill with all zeros and then fill its componenets as theyre calculated
        dfdSdfdSdEp = zero
        dfdSdfdSdEp(2, 2) = dfdSdfdSd22Ep
        dfdSdfdSdEp(2, ndir + 1) = dfdSdfdSd24Ep
        dfdSdfdSdEp(ndir + 1, 2) = dfdSdfdSd24Ep
        dfdSdfdSdEp(ndir + 1, ndir + 1) = dfdSdfdSd44Ep

        J1a = (schaefer_n - 1) * f**(schaefer_n - 2) * df * MATMUL(dfdSdfdS, dS)
        J1b = f**(schaefer_n - 1) * MATMUL(dfdSdfdSdEp, dS)
        J1c = f**(schaefer_n - 1) * MATMUL(dfdSdfdS, dSddEp)
        J1(:, i) = eye(:, i) - schaefer_n * schaefer_A * (J1a + J1b + J1c)
      END DO
      ! update according dEp according to newton raphson
      IF (ndir + nshr .eq. 6) THEN
        dEp = dEp - MATMUL(MInverse6x6(J1), J0)
      ELSE IF (ndir + nshr .eq. 4) THEN
        dEp = dEp - MATMUL(MInverse4x4(J1), J0)
      ELSE
        Call log%error('Schaefer material prepeak nonlinearity model only supports ndir + nshr=6 and 4 elements')
      END IF

      ! The newton raphson continually updates J0 (and as it converges J0) should
      ! approach 0. Determine its norm (and refer to this as the residual)
      residual = SQRT(DOT_PRODUCT(J0, J0))
      ! once we're within a certain tolerance break the loop
      if (residual .lt. schaefer_nr_tolerance) THEN
        ! If f is larger than previous step then additional plastic strain is predicted
        if (f > fp_old) THEN
          eps_vec_p_old = eps_vec_p_old + dEp
          fp_old = f
        ELSE
          Call log%debug_str('No change predicted')
        END IF
        Return
      END IF
      IF (MODULO(counter, counter_limit) .eq. 0) THEN
        Call log%debug_str('Maybe too many iterations occurred during newton-raphson convergence in schaefer sub')
        Call log%debug_int('counter', counter)
      END IF
    END DO
  END subroutine schaefer

  FUNCTION Getf(S, schaefer_a6, schaefer_b2, ndir, nshr) result(f)
    Double PRECISION, intent(IN) :: schaefer_a6
    Double PRECISION, intent(IN) :: schaefer_b2
    Integer, intent(IN) :: ndir, nshr
    Double PRECISION, intent(IN) :: S(ndir + nshr, 1)

    Double PRECISION :: f
    Double PRECISION :: S12
    Double PRECISION :: S22

    S22 = S(2, 1)
    S12 = S(ndir + 1, 1)
    f = SQRT(S22**2 + schaefer_a6 * S12**2) + schaefer_b2 * S22
    Return
  End FUNCTION Getf

  ! Calculates J0 and returns it. J0 is a variable used in the newton Raphson
  ! determination of dEp
  FUNCTION GetJ0(schaefer_n, schaefer_A, f, dfdSdfdS, dS, dEp, ndir, nshr) result(J0)
    Double PRECISION, intent(IN) :: schaefer_n
    Double PRECISION, intent(IN) :: schaefer_A
    Double PRECISION, intent(IN) :: f
    Integer, intent(IN) :: ndir, nshr
    Double PRECISION, intent(IN) :: dfdSdfdS(ndir + nshr, ndir + nshr)
    Double PRECISION, intent(IN) :: dS(ndir + nshr)
    Double PRECISION, intent(IN) :: dEp(ndir + nshr)
    Double PRECISION :: J0(ndir + nshr)

    J0 = dEp - schaefer_n * schaefer_A * f**(schaefer_n - 1) * MATMUL(dfdSdfdS, dS)
    Return
  End FUNCTION GetJ0
End Module schaefer_mod


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

!>    @brief rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of  pure water,
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] ismpl local sample index
!>    @return visf  [Pa s]
!>    @details
!>    rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of  pure water,\n
!>    given temperature (t, in C), and pressure (p,in Pa) at node(i,j,k)\n
!>    derived from the formulation given in:\n
!>          zylkovskij et al: models and methods summary for\n
!>          the fehmn application,\n
!>           ecd 22, la-ur-94-3787, los alamos nl, 1994.\n
!>    Speedy, R.J. (1987) Thermodynamic properties of supercooled water\n
!>          at 1 atm. Journal of Physical Chemistry, 91: 3354–3358.
!>    range of validity:\n
!>      pressures   0.01 - 110 mpa,\n
!>      temperature   15 - 350 °c and -46°c - 0°c\n
!>    input:\n
!>      pressure                            plocal [Pa]\n
!>      temperature                         tlocal in [C]\n
      DOUBLE PRECISION FUNCTION visf(i,j,k,ismpl)
        use arrays
        use mod_flow
        IMPLICIT NONE

        INTEGER i, j, k, ismpl
        DOUBLE PRECISION cf(20), bf(6)
        DOUBLE PRECISION ta, tb, tlocal, plocal, t, t2, t3, tred, p, &
          p2, p3, p4, tp, t2p, tp2

        DATA cf/0.17409149D-02, 0.18894882D-04, -0.66439332D-07, &
          -0.23122388D-09, -0.31534914D-05, 0.11120716D-07, &
          -0.48576020D-10, 0.28006861D-07, 0.23225035D-09, &
          0.47180171D-10, 0.10000000D+01, 0.10523153D-01, &
          -0.22658391D-05, -0.31796607D-06, 0.29869141D-01, &
          0.21844248D-03, -0.87658855D-06, 0.41690362D-03, &
          -0.25147022D-05, 0.22144660D-05/
!     new: after Speedy (1987) for T < 0 to -46 C
        DATA bf/26.312D0, -144.565D0, 1239.075D0, -8352.579D0, &
          31430.760, -48576.798D0/
!     end new

        plocal = pres(i,j,k,ismpl)*pa_conv1
        tlocal = temp(i,j,k,ismpl)
        IF (tlocal<-45D0) tlocal = -45.D0

        IF (tlocal<0.D0) THEN
! tloCal = 0.d0
!     new: after Speedy (1987) for T < 0 to -46 C
          tred = (tlocal+273.15D0-227.15D0)/227.15D0
          visf = bf(1)/sqrt(tred) + bf(2) + bf(3)*tred + &
            bf(4)*tred*tred + bf(5)*tred*tred*tred + &
            bf(6)*tred*tred*tred*tred
          visf = visf*0.001
        ELSE
!     end new
          IF (tlocal>300.D0) tlocal = 300.D0

          p = plocal
          t = tlocal
          p2 = p*p
          p3 = p2*p
          p4 = p3*p
          t2 = t*t
          t3 = t2*t
          tp = p*t
          t2p = t2*p
          tp2 = t*p2

          ta = cf(1) + cf(2)*p + cf(3)*p2 + cf(4)*p3 + cf(5)*t + &
            cf(6)*t2 + cf(7)*t3 + cf(8)*tp + cf(10)*t2p + cf(9)*tp2
          tb = cf(11) + cf(12)*p + cf(13)*p2 + cf(14)*p3 + cf(15)*t + &
            cf(16)*t2 + cf(17)*t3 + cf(18)*tp + cf(20)*t2p + &
            cf(19)*tp2
          visf = ta/tb
        END IF

        RETURN
      END


C
C**********************************************************************C
C**********************************************************************C
C**********************************************************************C
C
      SUBROUTINE SETFPOCB(ITYPE)
C
C **  THIS SUBROUTINE IS PART OF  EFDC-FULL VERSION 1.0a
C
C **  LAST MODIFIED BY JOHN HAMRICK ON 1 NOVEMBER 2001
C
C----------------------------------------------------------------------C
C
C CHANGE RECORD
C DATE MODIFIED     BY                 DATE APPROVED    BY
C----------------------------------------------------------------------C
C
C**********************************************************************C
C
C **  SUBROUTINE SETFPOC SETS FPOC BASED ON SEDIMENT BED COMPOSITION
C **  FUNCTIONAL RELATIONSHIPS FOR HOUSATONIC RIVER PROVIDED BY
C **  HYDROQUAL DOCUMENT DATED MARCH 17, 2003
C **  NOTE THAT PER CENTS IN PROVIDED RELATIONS ARE CONVERTED
C **  TO FRACTIONS CONSISTENT WITH EFDC VARIABLES
C
C**********************************************************************C
C
      USE GLOBAL

      REAL TMPVAL, TMPVAL1, TMPVAL2
C###########################################################################
C HQI Change to include spatially varying, but time constant bulk foc and
C pseudo-foc
      REAL PREDFOCB
C RM, 02/29/04
C###########################################################################

C
C
C**********************************************************************C
C
C   NOTE LIMIT VALUES TO LESS THAN 100 %
C
      IF(ITYPE.EQ.0) THEN
C
C     INITIALIZE ALL FULL BED LAYERS
C
C     COHESIVE SEDIMENT (CLASS 1)
C
        DO K=1,KB
          DO L=2,LA
            IF(K.LE.KBT(L))THEN
              IF(VFRBED(L,K,1).GT.0.0)THEN
C#######################################################################
C     09/18/03, RM, HQI, relationship for cohesives corrected and
C     regression based foc limited to 100%
C     02/29/04, RM, HQI, log-space to arithmetic space conversion
c             STFPOCB(L,K,1)=0.8657/((100.*VFRBED(L,K,1))**1.3326)
                STFPOCB(L,K,1)=0.0384*((100.*VFRBED(L,K,1))**0.0366)
                STFPOCB(L,K,1)=LOG(STFPOCB(L,K,1))
                STFPOCB(L,K,1)=STFPOCB(L,K,1) + ((0.5955**2)/2)
                STFPOCB(L,K,1)=EXP(STFPOCB(L,K,1))
                IF(STFPOCB(L,K,1).GT.1.) STFPOCB(L,K,1)=1.0
C#######################################################################
              ELSE
                STFPOCB(L,K,1)=0.0
              ENDIF
            ENDIF
          ENDDO
        ENDDO
C
C     COARSER NONCOHESIVE SEDIMENT (CLASS 2)
C#######################################################################
C     09/18/03, RM, HQI, this is Non-Cohesive 1
C#######################################################################

        DO K=1,KB
          DO L=2,LA
            IF(K.LE.KBT(L))THEN
              IF(VFRBED(L,K,2).GT.0.0)THEN
C#######################################################################
C     09/18/03, RM, HQI, Change to account for NC4 and
C     regression based foc limited to 100%
C     02/29/04, RM, HQI, log-space to arithmetic space conversion
                TMPVAL2=( (100.*VFRBED(L,K,2))**0.9189)
C             TMPVAL=VFRBED(L,K,3)/(VFRBED(L,K,1)+VFRBED(L,K,2))
                TMPVAL=VFRBED(L,K,1)/
     +             (VFRBED(L,K,2)+VFRBED(L,K,3)+VFRBED(L,K,4))
                TMPVAL1=TMPVAL**0.9204
                STFPOCB(L,K,2)=0.7428*TMPVAL1/TMPVAL2
                STFPOCB(L,K,2)=LOG(STFPOCB(L,K,2))
                STFPOCB(L,K,2)=STFPOCB(L,K,2) + ((1.1371**2)/2)
                STFPOCB(L,K,2)=EXP(STFPOCB(L,K,2))
                IF(STFPOCB(L,K,2).GT.1.) STFPOCB(L,K,2)=1.0
C#######################################################################
              ELSE
                STFPOCB(L,K,2)=0.0
              ENDIF
            ENDIF
          ENDDO
        ENDDO
C
C     FINER NONCOHESIVE SEDIMENT (CLASS 2)
C#######################################################################
C     09/18/03, RM, HQI, this is Non-Cohesive 2
C#######################################################################

        DO K=1,KB
          DO L=2,LA
            IF(K.LE.KBT(L))THEN
              IF((VFRBED(L,K,3)+VFRBED(L,K,4)).GT.0.0)THEN
C#######################################################################
C     09/18/03, RM, HQI, regression corrected, account for NC4 and
C     regression based foc limited to 100%
C     02/29/04, RM, HQI, log-space to arithmetic space conversion
c             STFPOCB(L,K,3)=0.033*((100.*VFRBED(L,K,3))**0.152)
                STFPOCB(L,K,3)=0.4084/
     +             ((100.*(VFRBED(L,K,3)+VFRBED(L,K,4)))**1.116)
                STFPOCB(L,K,3)=LOG(STFPOCB(L,K,3))
                STFPOCB(L,K,3)=STFPOCB(L,K,3) + ((1.4436**2)/2)
                STFPOCB(L,K,3)=EXP(STFPOCB(L,K,3))
                IF(STFPOCB(L,K,3).GT.1.) STFPOCB(L,K,3)=1.0
                STFPOCB(L,K,4)=STFPOCB(L,K,3)
C#######################################################################
              ELSE
                STFPOCB(L,K,3)=0.0
                STFPOCB(L,K,4)=0.0
              ENDIF
            ENDIF
          ENDDO
        ENDDO
C
C###########################################################################
C HQI Change to include spatially varying, but time constant bulk foc and
C pseudo-foc
        DO K=1,KB
          DO L=2,LA
            IF(K.LE.KBT(L))THEN
              PREDFOCB = (STFPOCB(L,K,1)*VFRBED(L,K,1)) +
     +                (STFPOCB(L,K,2)*VFRBED(L,K,2)) +
     +                (STFPOCB(L,K,3)*VFRBED(L,K,3)) +
     +                (STFPOCB(L,K,4)*VFRBED(L,K,4))
	        IF(PREDFOCB.GT.0.0)THEN
                STFPOCB(L,K,1) = STFPOCB(L,K,1)*PFPOCB(L,K)/PREDFOCB
                STFPOCB(L,K,2) = STFPOCB(L,K,2)*PFPOCB(L,K)/PREDFOCB
                STFPOCB(L,K,3) = STFPOCB(L,K,3)*PFPOCB(L,K)/PREDFOCB
                STFPOCB(L,K,4) = STFPOCB(L,K,4)*PFPOCB(L,K)/PREDFOCB
	        ENDIF
              IF(STFPOCB(L,K,1).GT.1.) STFPOCB(L,K,1)=1.0
              IF(STFPOCB(L,K,2).GT.1.) STFPOCB(L,K,2)=1.0
              IF(STFPOCB(L,K,3).GT.1.) STFPOCB(L,K,3)=1.0
              IF(STFPOCB(L,K,4).GT.1.) STFPOCB(L,K,4)=1.0
            ENDIF
          ENDDO
        ENDDO
C RM, 02/29/04
C###########################################################################
      ENDIF
C
CC**********************************************************************C
C
      IF(ITYPE.EQ.1) THEN
C
C     UPDATE TOP LAYER OF BED
C
C     COHESIVE SEDIMENT (CLASS 1)
C
        DO L=2,LA
          K=KBT(L)
          IF(VFRBED(L,K,1).GT.0.0)THEN
C#######################################################################
C     09/18/03, RM, HQI, relationship for cohesives corrected and
C     regression based foc limited to 100%
C     02/29/04, RM, HQI, log-space to arithmetic space conversion
c           STFPOCB(L,K,1)=0.8657/((100.*VFRBED(L,K,1))**1.3326)
            STFPOCB(L,K,1)=0.0384*((100.*VFRBED(L,K,1))**0.0366)
            STFPOCB(L,K,1)=LOG(STFPOCB(L,K,1))
            STFPOCB(L,K,1)=STFPOCB(L,K,1) + ((0.5955**2)/2)
            STFPOCB(L,K,1)=EXP(STFPOCB(L,K,1))
            IF(STFPOCB(L,K,1).GT.1.) STFPOCB(L,K,1)=1.0
C#######################################################################
          ELSE
            STFPOCB(L,K,1)=0.0
          ENDIF
        ENDDO
C
C     COARSER NONCOHESIVE SEDIMENT (CLASS 2)
C#######################################################################
C     09/18/03, RM, HQI, this is Non-Cohesive 1
C#######################################################################

        DO L=2,LA
          K=KBT(L)
          IF(VFRBED(L,K,2).GT.0.0) THEN
C#######################################################################
C     09/18/03, RM, HQI, Change to account for NC4 and
C     regression based foc limited to 100%
C     02/29/04, RM, HQI, log-space to arithmetic space conversion
C           TMPVAL=VFRBED(L,K,3)/(VFRBED(L,K,1)+VFRBED(L,K,2))
            TMPVAL2=( (100.*VFRBED(L,K,2))**0.9189)
            TMPVAL=VFRBED(L,K,1)/
     +             (VFRBED(L,K,2)+VFRBED(L,K,3)+VFRBED(L,K,4))
            TMPVAL1=TMPVAL**0.9204
            STFPOCB(L,K,2)=0.7428*TMPVAL1/TMPVAL2
            STFPOCB(L,K,2)=LOG(STFPOCB(L,K,2))
            STFPOCB(L,K,2)=STFPOCB(L,K,2) + ((1.1371**2)/2)
            STFPOCB(L,K,2)=EXP(STFPOCB(L,K,2))
            IF(STFPOCB(L,K,2).GT.1.) STFPOCB(L,K,2)=1.0
C#######################################################################
          ELSE
            STFPOCB(L,K,2)=0.0
          ENDIF
        ENDDO
C
C     FINER NONCOHESIVE SEDIMENT (CLASS 2)
C#######################################################################
C     09/18/03, RM, HQI, this is Non-Cohesive 2
C#######################################################################

        DO L=2,LA
          K=KBT(L)
          IF(VFRBED(L,K,3).GT.0.0)THEN
C#######################################################################
C     09/18/03, RM, HQI, regression corrected, account for NC4 and
C     regression based foc limited to 100%
C     02/29/04, RM, HQI, log-space to arithmetic space conversion
c           STFPOCB(L,K,3)=0.033*((100.*VFRBED(L,K,3))**0.152)
            STFPOCB(L,K,3)=0.4084/
     +             ((100.*(VFRBED(L,K,3)+VFRBED(L,K,4)))**1.116)
            STFPOCB(L,K,3)=LOG(STFPOCB(L,K,3))
            STFPOCB(L,K,3)=STFPOCB(L,K,3) + ((1.4436**2)/2)
            STFPOCB(L,K,3)=EXP(STFPOCB(L,K,3))
            IF(STFPOCB(L,K,3).GT.1.) STFPOCB(L,K,3)=1.0
            STFPOCB(L,K,4)=STFPOCB(L,K,3)
C#######################################################################
          ELSE
            STFPOCB(L,K,3)=0.0
            STFPOCB(L,K,4)=0.0
          ENDIF
        ENDDO
C###########################################################################
C HQI Change to include spatially varying, but time constant bulk foc and
C pseudo-foc
        DO L=2,LA
          K=KBT(L)
          PREDFOCB = (STFPOCB(L,K,1)*VFRBED(L,K,1)) +
     +          (STFPOCB(L,K,2)*VFRBED(L,K,2)) +
     +          (STFPOCB(L,K,3)*VFRBED(L,K,3)) +
     +          (STFPOCB(L,K,4)*VFRBED(L,K,4))
	    IF(PREDFOCB.GT.0.0)THEN
            STFPOCB(L,K,1) = STFPOCB(L,K,1)*PFPOCB(L,K)/PREDFOCB
            STFPOCB(L,K,2) = STFPOCB(L,K,2)*PFPOCB(L,K)/PREDFOCB
            STFPOCB(L,K,3) = STFPOCB(L,K,3)*PFPOCB(L,K)/PREDFOCB
            STFPOCB(L,K,4) = STFPOCB(L,K,4)*PFPOCB(L,K)/PREDFOCB
	    ENDIF
          IF(STFPOCB(L,K,1).GT.1.) STFPOCB(L,K,1)=1.0
          IF(STFPOCB(L,K,2).GT.1.) STFPOCB(L,K,2)=1.0
          IF(STFPOCB(L,K,3).GT.1.) STFPOCB(L,K,3)=1.0
          IF(STFPOCB(L,K,4).GT.1.) STFPOCB(L,K,4)=1.0
        ENDDO
C RM, 02/29/04
C###########################################################################
C
      ENDIF
C
C**********************************************************************C
C
      RETURN
      END


SUBROUTINE  CALC (OLDTMP, No_Rows)
  use simsphere_mod, only: xlat, xlong, degs_to_radians, rot_rate_earth, &
                           timend, strtim, outtt, atemp, otemp, tscren,  &
                           t, frveg, cf
  implicit none

  integer :: No_Rows
  real :: Lat_in_radians
!  integer K

  real :: OLDTMP, DECTIM, out_time_intv

! Nobody would assume these days that a decimal lat/lon refers to
! degrees and minutes (e.g. 39.25 N is 39 degrees, 25 minutes), so
! I'm removing the below statements to leave the interpretation as
! decimal degrees of latitude and longitude.  A.A.P.  20190926
!  K = XLAT
!  XLAT= (XLAT-K) / 0.6 + K
!  K = XLONG
!  XLONG = (XLONG-K) / 0.6 + K

! Convert Lat to radians, calc Coriolis force.

  Lat_in_radians = XLAT * Degs_To_Radians
  CF = 2 * rot_rate_earth * SIN(Lat_in_radians)

! Time conversions

  TIMEND = DECTIM(TIMEND) ! Convert to Decimal time
  STRTIM = DECTIM(STRTIM)

!  out_time_intv = outtt / 60
  outtt = dectim(outtt)
  out_time_intv = outtt
! Not needed with dectim(outtt) call -TJC
!  out_time_intv = dectim(out_time_intv)
  No_Rows = INT(((Timend - strtim)) / out_time_intv) + 1

! Store and initialize temperatures

  OLDTMP = ATEMP
  t(1) = Atemp + 0.5
  OTEMP = TSCREN - 2

  FRVEG  = FRVEG / 100  ! Vegetation % as a fraction

  return
end

real pure function dectim(t)
  implicit none
! Converts time formatted as "HHMM" (2-digit hours and 2-digit minutes) to decimal seconds
  real, intent(in) :: t
  real :: hour, minute

  minute = modulo(t,100.0)
  hour = (t - minute)/100.0

  dectim = ( hour + (minute/60.0) ) * 3600
end function dectim


module timedisc_probe_mod

use constants_mod

contains

pure subroutine timedisc_probe(quad,flux,state)

    use mesh_types_mod, only: quad_t
    use share_mod, only: rt => runtime

    use timedisc_const_mod

    type(quad_t), intent(in)    :: quad

# if PP_N_DIMS == 2
    real(dp), intent(in)        :: flux(N_NODES,N_NODES,N_VARS)
    real(dp), intent(out)       :: state(N_NODES,N_NODES,N_VARS)
# elif PP_N_DIMS == 3
    real(dp), intent(in)        :: flux(N_NODES,N_NODES,N_NODES,N_VARS)
    real(dp), intent(out)       :: state(N_NODES,N_NODES,N_NODES,N_VARS)
# endif

    associate(dt => rt%timestep, &
              uu => quad%pld%hydro%state, &
              r0 => quad%aux%timedisc%register0, &
              r1 => quad%aux%timedisc%register1)

    select case(rt%rkstage)

        case(1)
            state =                uu + A3 * dt * flux

        case(2)
            state = B1 * r0 + B2 * uu + B3 * dt * flux

        case(3)
            state = C1 * r0 + C2 * uu + C3 * dt * flux

        case(4)
            state = D1 * r0 + D2 * uu + D3 * dt * flux

        case(5)
            state = E1 * r0 + E2 * uu + E3 * dt * flux + r1

    end select
    end associate

end subroutine

end module


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE CASMO (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN, NNNOLD,
     &   NIT, EPS, RO)
C***********************************************************************

C  SUBROUTIINE CASMO  =  CENTROID-AREA-PULL METHOD MESH SMOOTHING

C***********************************************************************

C  NOTE:
C     IN THIS METHOD EACH NODE IS PULLED TOWARD THE CENTROIDS OF
C     ADJACENT ELEMENTS BY FORCES PROPORTIONAL TO THE RESPECTIVE
C     ELEMENT AREAS.
C     IDEA BY STEVE PETTY AND RONDALL JONES

C***********************************************************************

C  VARIABLES USED:
C     NIT  =  MAX NUMBER OF ITERATIONS TO DO
C     EPS  =  NODE MOVEMENT TOLERANCE FOR CONVERGENCE
C     RO   =  UNDER OR OVER-RELAXATION FACTOR.

C***********************************************************************

      DIMENSION NODES(4)
      DIMENSION KLIST(20), AREA(20), XCEN(20), YCEN(20)
      DIMENSION LXK(4, MXND), KXL(2, 3*MXND), NXL(2, 3*MXND)
      DIMENSION LXN(4, MXND), XN(MXND), YN(MXND)

      LOGICAL ERR, BIG, CCW

C  ITERATION LOOP

      DO 140 IT = 1, NIT
         BIG = .FALSE.

C  NODE LOOP

         DO 130 NODE = NNNOLD + 1, NNN

C  SKIP CONTINUATIONS AND BOUNDARY NODES

            IF((LXN(1, NODE).GT.0).AND.(LXN(2, NODE).GT.0))THEN

C  GET ELEMENT LIST (IGNORE ERR IF CAUSED BY TOO MANY ELEMENTS)

               CALL GKXN (MXND, KXL, LXN, NODE, NUMK, KLIST, ERR)
               IF((ERR).AND.(NUMK.LT.20))RETURN

C  GET AREAS AND CENTROIDS

               DO 110 IK = 1, NUMK
                  KK = KLIST(IK)
                  CCW = .TRUE.
                  CALL GNXKA (MXND, XN, YN, KK, NODES, AREA(IK), LXK,
     &               NXL, CCW)
                  XSUM = 0.
                  YSUM = 0.
                  DO 100 I = 1, 4
                     NN = NODES(I)
                     XSUM = XSUM + XN(NN)
                     YSUM = YSUM + YN(NN)
  100             CONTINUE
                  XCEN(IK) = 0.25*XSUM
                  YCEN(IK) = 0.25*YSUM
  110          CONTINUE

C  COMPUTE AND SUM THE FORCE VECTORS

               FX = 0.
               FY = 0.
               SUMW = 0.
               DO 120 IK = 1, NUMK
                  DX = XCEN(IK) - XN(NODE)
                  DY = YCEN(IK) - YN(NODE)
                  WEIGHT = AREA(IK)
                  SUMW = SUMW + WEIGHT
                  FX = FX + WEIGHT*DX
                  FY = FY + WEIGHT*DY
  120          CONTINUE

C  NORMALIZE THE RESULTANT VECTOR

               RSUMW = 1.0/SUMW
               FX = FX*RSUMW
               FY = FY*RSUMW

C  MOVE THE NODE

               DELX = RO*FX
               DELY = RO*FY
               XN(NODE) = XN(NODE) + DELX
               YN(NODE) = YN(NODE) + DELY
            ENDIF
  130    CONTINUE
         IF(.NOT.BIG)RETURN
  140 CONTINUE
      RETURN
      END


!=======================================================================
   SUBROUTINE vbsplvd(t, kg, ni, x, nderiv, dbiatx)
!=======================================================================
!
!  This routine calculates the values of the B-splines and their deriva-
!  tives, of order up to nderiv, that do not vanish at x(i), i=1,..ni
!  There are ks such B-splines at each point.
!
!  This routine is a vector version of bsplvd written by C. de Boor,
!  ``A Practical Guide to Splines".
!
!  subroutine contained: vbsplvb
!
!  calling sequence:
!       vbsplvd
!          ||
!       vbsplvb
!
!-----------------------------------------------------------------------
!  on entry
!  --------
!  t     the knot array, of length nt >=nv+2ks-1.  It is assumed
!        that t(i) < t(i+1) for each interval containing an x(i)
!        Division by zero will result otherwise (in vbsplvb).
!
!  kg    gives the beginning interval from which the B-splines are
!        evaluated at the Gaussian points.
!
!  ni    the number of intervals in which B-splines are to be evaluated
!        at all Gaussian points, its uplimit is nt.
!
!  x     the point array at which these values are sought,
!        one per interval, of length ni.
!
!  nderiv   an integer indicating that values of B-splines and their
!        derivatives up to but not including the  nderiv-th  are asked
!        for.
!
!  working area
!  ------------
!  w31   a three dimensional array, w31(i,j,m) (j=1,..,ks m=1,..,ks) con-
!        tains B-coeff.s of the derivatives of a certain order of the
!        ks B-splines of interest at point x(i)
!
!  w1,w2      one dimensional arrays
!
!  on return
!  ---------
!  dbiatx     a three dimensional array. its entry (i,j,m) contains
!        value of  (m-1)st  derivative of  (l-ks+j)-th B-spline of
!        order ks at point x(i) for knot sequence t, i=1..ni,
!        j=m..ks; m=1..nderiv;and l=kg..kg+ni-1
!
!  method
!  ------
!  values at x(i) of all the relevant B-splines of order ks,ks-1,...,
!  ks+1-nderiv  are generated via vbsplvb and stored temporarily
!  in dbiatx. then, the B-coeffs of the required derivatives of the
!  B-splines of interest are generated by differencing, each from the
!  preceding one of lower order, and combined with the values of B-
!  splines of corresponding order in dbiatx to produce the desired
!  values.
!----------------------------------------------------------------------

      USE spline_param

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: kg, ni, nderiv
      REAL(KIND=8), DIMENSION(ns + ks), INTENT(IN) :: t
      REAL(KIND=8), DIMENSION(nv, ks, ks), INTENT(INOUT):: dbiatx
      REAL(KIND=8), DIMENSION(ni), INTENT(IN):: x

      ! local variables
      REAL(KIND=8):: fkpimm
      REAL(KIND=8), DIMENSION(ni):: w1, w2
      REAL(KIND=8), DIMENSION(ni, ks, ks):: w31
      REAL(KIND=8), DIMENSION(ni, ks) :: deltar, deltal
      INTEGER:: i, j, n, m, mhigh, kp1, jhigh, ideriv
      INTEGER:: ldummy, kpimm, jlow, jpimid, il

      mhigh = MAX(MIN(nderiv, ks), 1)   !mhigh is usually equal to nderiv.
      kp1 = ks + 1
      jhigh = kp1 - mhigh
      CALL vbsplvb(kg, ni, x, jhigh, 1, dbiatx)
      IF (mhigh == 1) RETURN

      ! ..the first row of dbiatx always contains the B-spline values
      ! ..for the current order. these are stored in row ks+1-current
      ! ..order before vbsplvb is called to put values for the next
      ! ..higher order on top of it. Vbsplvb only uses the first two dimensions

      ideriv = mhigh
      DO m = 2, mhigh
         jpimid = 1
         DO j = ideriv, ks
            dbiatx(1:ni, j, ideriv) = dbiatx(1:ni, jpimid, 1)
            jpimid = jpimid + 1
         END DO
         ideriv = ideriv - 1
         jhigh = kp1 - ideriv
         CALL vbsplvb(kg, ni, x, jhigh, 2, dbiatx)
      END DO

      ! at this point,  b(.,n-ks+i, ks+1-j)(x) is in dbiatx(.,i,j) for
      ! n=kg..kg+ni-1,i=j..ks,j=1..mhigh('='nderiv).in particular,the
      ! first row of  dbiatx  is already in final form. to obtain cor-
      ! responding derivatives of B-splines in subsequent rows, gene-
      ! rate their B-repr. by differencing, then evaluate at x(.).

      jlow = 1
      DO i = 1, ks
         w31(1:ni, jlow:ks, i) = 0.d0
         jlow = i
         w31(1:ni, i, i) = 1.d0
      END DO

      ! at this point, w31(.,.,j) contains the B-coeffs for the j-th of the
      ! ks B-splines of interest here.

      DO m = 2, mhigh
         kpimm = kp1 - m
         fkpimm = kpimm
         i = ks
         il = 0

         ! for j=1,...,ks, construct B-coeffs of  (m-1)st  derivative of
         ! B-splines from those for preceding derivative by differencing
         ! and store again in  w31(.,.,j). the fact that w31(i,j) = 0  for
         ! i < j is used.

         DO ldummy = 1, kpimm
            DO n = kg - il, ni + kg - il - 1
               w1(n - kg + il + 1) = fkpimm/(t(n + kpimm) - t(n))
            END DO

            ! the assumption that t(n) < t(n+1) makes denominator
            ! in w1(1..ni) nonzero.

            DO j = 1, i
               w31(1:ni, i, j) = (w31(1:ni, i, j) - w31(1:ni, i - 1, j))*w1(1:ni)
            END DO
            il = il + 1
            i = i - 1
         END DO

         ! for i=1,...,ks, combine B-coeffs a(.,.,i) with B-spline values
         ! stored in dbiatx(.,.,m) to get value of (m-1)st  derivative of
         ! i-th B-spline (of interest here) at x(.), and store in
         ! dbiatx(.,i,m). storage of this value over the value of a B-spline
         ! of order m there is safe since the remaining B-spline derivat-
         ! ive of the same order do not use this value due to the fact
         ! that  a(.,j,i) = 0  for j .lt. i .

         DO i = 1, ks
            w2(1:ni) = 0.d0
            jlow = MAX(i, m)
            DO j = jlow, ks
               w2(1:ni) = w2(1:ni) + w31(1:ni, j, i)*dbiatx(1:ni, j, m)
            END DO
            dbiatx(1:ni, i, m) = w2(1:ni)
         END DO

      END DO

   CONTAINS

      !===================================================================
      SUBROUTINE vbsplvb(kg, ni, x, jhigh, index, biatx)
         !=====================================================================
         !  This routine calculates the values of all possibly nonzero B-splines
         !  at x(i) (i=1,..ni) of order
         !               jout=max(jhigh,(j+1)*(index-1))
         !  with knot sequence  t .
         !
         !  This routine is a vector version of bsplvb written by C. de Boor,
         !  "A Practical Guide to Splines", Chapter X, page 135
         !
         !  on entry
         !  --------
         !  t    -  knot sequence, of length nt=ns+ks, assumed to be nonde-
         !          creasing, that is t(i) <= t(i+1)
         !
         !  jhigh-  choose jhigh=1 to get the B-spline values directly
         !            by calling vbsplvb.
         !
         !  kg   -  gives the beginning interval from which the B-splines
         !           are to be evaluated at Gaussin points.
         !
         !  ni   -  the number of intervals in which B-splines are
         !            evaluated at all Gaussian points, its uplimit is nv.
         !
         !  x    -  the points at which the B-splines are to be evaluated,
         !            its length is ni,
         !
         !  index-  integers which determine the order  jout = max(jhigh,
         !            (j+1)*(index-1))  of the B-splines whose values at x(i)
         !            are to be returned.  index is used to avoid recalcula-
         !            tions when several columns of the triangular array of
         !            B-spline values are needed (e.g., in vbsplvd ).
         !            More precisely,
         !                     if index = 1 ,
         !            the calculation starts from scratch and the entire
         !            triangular array of B-spline values of orders
         !            1,2,...,jhigh is generated, order by order ,
         !            i.e., column by column .
         !                     if  index = 2 ,
         !            only the B-spline values of order  j+1, j+2, ..., jout
         !            are generated, the assumption being that  biatx,j,
         !            deltal,deltar are, on  entry, as they were on exit at the
         !            previous call. In particular, if  jhigh = 0, then
         !            jout = j+1, i.e., just the next column of B-spline
         !            values is generated.
         !
         !  working area
         !  ------------
         !  deltal, deltar: two dimensional arrays
         !  term, saved:    one dimensional arrays.
         !
         !  on return
         !  ---------
         !  biatx.....two dimensional array, with biatx(j-k+1,i)(j=k..ni)
         !        containing the value at x(j-k+1) of the polynomial of order
         !        jout which agrees with the B-spline b(j-jout+1,jout,t) on
         !        the interval (t(j),t(j+1)).
         !
         !  method
         !  ------
         !  The recurrence relation
         !
         !                       x - t(i)              t(i+j+1) - x
         !     b(i,j+1)(x)  =  -----------b(i,j)(x) + ---------------b(i+1,j)(x)
         !                     t(i+j)-t(i)            t(i+j+1)-t(i+1)
         !
         !  is used (repeatedly) to generate the (j+1)-vector  b(l-j,j+1)(x),
         !  ...,b(l,j+1)(x)  from the j-vector  b(l-j+1,j)(x),...,
         !  b(l,j)(x), storing the new values in  biatx  over the old. the
         !  facts that
         !            b(i,1) = 1  if  t(i) <= x < t(i+1)
         !  and that
         !            b(i,j)(x) = 0  unless  t(i) <= x < t(i+j)
         !  are used. the particular organization of the calculations follows al-
         !  gorithm  (8)  in chapter x of the text.
         !-----------------------------------------------------------------------

         USE spline_param
         IMPLICIT NONE
         REAL(KIND=8), DIMENSION(nv, ks), INTENT(INOUT):: biatx
         REAL(KIND=8), DIMENSION(nv), INTENT(IN):: x
         INTEGER, INTENT(IN):: kg, ni, jhigh, index

         ! .. Local variables
         INTEGER:: i, jp1, m
         INTEGER, SAVE:: j = 1
         REAL(KIND=8), DIMENSION(ni) :: term, saved

         IF (index == 1) THEN
            j = 1
            biatx(1:ni, 1) = 1.d0
            IF (j >= jhigh) RETURN
         END IF

         DO
            jp1 = j + 1
            saved(1:ni) = 0.d0

            DO i = 1, ni
               deltar(i, j) = t(i + kg - 1 + j) - x(i)
               deltal(i, j) = x(i) - t(i + kg - j)
            END DO

            DO m = 1, j
               DO i = 1, ni
                  term(i) = biatx(i, m)/(deltar(i, m) + deltal(i, jp1 - m))
                  biatx(i, m) = saved(i) + deltar(i, m)*term(i)
                  saved(i) = deltal(i, jp1 - m)*term(i)
               END DO
            END DO

            biatx(1:ni, jp1) = saved(1:ni)
            j = jp1
            IF (j >= jhigh) EXIT
         END DO
      END SUBROUTINE vbsplvb

   END SUBROUTINE vbsplvd


*DECK ZSHCH
      SUBROUTINE ZSHCH (ZR, ZI, CSHR, CSHI, CCHR, CCHI)
C***BEGIN PROLOGUE  ZSHCH
C***SUBSIDIARY
C***PURPOSE  Subsidiary to ZBESH and ZBESK
C***LIBRARY   SLATEC
C***TYPE      ALL (CSHCH-A, ZSHCH-A)
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C     ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y)
C     AND CCH=COSH(X+I*Y), WHERE I**2=-1.
C
C***SEE ALSO  ZBESH, ZBESK
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  ZSHCH
C
      DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR
C***FIRST EXECUTABLE STATEMENT  ZSHCH
      SH = SINH(ZR)
      CH = COSH(ZR)
      SN = SIN(ZI)
      CN = COS(ZI)
      CSHR = SH*CN
      CSHI = CH*SN
      CCHR = CH*CN
      CCHI = SH*SN
      RETURN
      END


      subroutine impsvb(u,w,v,m,n,b,x)
c
c     + + + PURPOSE + + +
c
c     SR IMPSVB is an impoundment element singular value
c     backsubstitution subroutine.  It is utilized in
c     developing least squares fits for a variety of
c     functions.  It is taken directly from the book
c     "Numerical Recipes in Fortran".
c
c     Called from: IMPINT
c
c     Copyright (C) 1986, 1992 Numerical Recipes Software
c
c     Permission is granted for use only within USDA Water Erosion
c     Prediction Project code
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      integer m, n
      real b(100), u(100,5), v(5,5), w(5), x(5)
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      integer i, j, jj
      real s, tmp(500)
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      do 20 j = 1, n
        s = 0.0
c
        if (w(j).ne.0.) then
c
          do 10 i = 1, m
            s = s + u(i,j) * b(i)
   10     continue
c
          s = s / w(j)
        end if
c
        tmp(j) = s
c
   20 continue
c
      do 40 j = 1, n
        s = 0.0
c
        do 30 jj = 1, n
          s = s + v(j,jj) * tmp(jj)
   30   continue
c
        x(j) = s
   40 continue
c
      return
      end


      MODULE trsub_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.4G  21:23:38  03/14/06
      REAL(KIND(0.0D0)) FUNCTION trsub (UL, X, UR, L1, LM, NDIM)
      USE vast_kind_param,ONLY: DOUBLE
      integer, INTENT(IN) :: L1
      integer, INTENT(IN) :: LM
      integer, INTENT(IN) :: NDIM
      real(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: UL
      real(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: X
      real(DOUBLE), DIMENSION(NDIM,NDIM), INTENT(IN) :: UR
      END FUNCTION
      END INTERFACE
      END MODULE


program fft_test
use precision
use cufft
complex(fp_kind) ,allocatable:: a(:),b(:)
complex(fp_kind),device,allocatable:: a_d(:),b_d(:)

integer:: n
integer:: plan

n=8

! allocate arrays on the host
allocate (a(n),b(n))

! allocate arrays on the device
allocate (a_d(n))
allocate (b_d(n))

!initialize arrays on host
a=1

!copy arrays to device
a_d=a

! Print initial array
print *, "Array A:"
print *, a

! Initialize the plan
call cufftPlan1D(plan,n,CUFFT_Z2Z,1)

! Execute FFTs
call cufftExecZ2Z(plan,a_d,b_d,CUFFT_FORWARD)

call cufftExecZ2Z(plan,b_d,b_d,CUFFT_INVERSE)

! Copy results back to host
b=b_d

! Print initial array
print *, "Array B"
print *, b

!release memory on the host
deallocate (a,b)

!release memory on the device
deallocate (a_d,b_d)

! Destroy the plan
call cufftDestroy(plan)

end program fft_test


MODULE ReflectMod

  USE bellhopMod
  IMPLICIT NONE
CONTAINS

  SUBROUTINE Reflect2D( is, HS, BotTop, nBdry3d, z_xx, z_xy, z_yy, kappa_xx, kappa_xy, kappa_yy, RefC, Npts, xs, tradial )

    !USE norms
    USE RefCoef
    USE sspMod
    USE Cone   ! if using analytic formulas for the cone (conical seamount)

    INTEGER,              INTENT( IN ) :: Npts
    REAL     (KIND=8),    INTENT( IN ) :: xs( 3 ), tradial( 2 )
    REAL     (KIND=8),    INTENT( IN ) :: nBdry3d( 3 )                    ! Normal to the boundary
    CHARACTER (LEN=3),    INTENT( IN ) :: BotTop                          ! Flag indicating bottom or top reflection
    TYPE( HSInfo ),       INTENT( IN ) :: HS                              ! half-space properties
    TYPE(ReflectionCoef), INTENT( IN ) :: RefC( NPts )                    ! reflection coefficient
    INTEGER,              INTENT( INOUT ) :: is
    INTEGER           :: is1
    REAL     (KIND=8) :: c, cimag, gradc( 2 ), crr, crz, czz, rho         ! derivatives of sound speed
    REAL     (KIND=8) :: RM, RN, Tg, Th, rayt( 2 ), rayn( 2 ), rayt_tilde( 2 ), rayn_tilde( 2 ), cnjump, csjump  ! for curvature change
    REAL     (KIND=8) :: ck, co, si, cco, ssi, pdelta, rddelta, sddelta   ! for beam shift
    COMPLEX  (KIND=8) :: gamma1, gamma2, gamma1Sq, gamma2Sq, GK, Refl, ch, a, b, d, sb, delta, ddelta
    REAL     (KIND=8) :: kappa                                            ! Boundary curvature
    REAL     (KIND=8) :: tBdry( 2 ), nBdry( 2 )                           ! tangent, normal to boundary
    TYPE(ReflectionCoef) :: RInt
    REAL     (KIND=8) :: z_xx, z_xy, z_yy, &
         t_rot( 2 ), n_rot( 2 ), RotMat( 2, 2 ), kappaMat( 2, 2 ), DMat( 2, 2 )   ! for cone reflection
    REAL     (KIND=8) :: kappa_xx, kappa_xy, kappa_yy

    is  = is + 1
    is1 = is + 1

    ! following should perhaps be pre-calculated in Bdry3DMod
    nBdry( 1 ) = DOT_PRODUCT( nBdry3d( 1 : 2 ), tradial )
    nBdry( 2 ) = nBdry3d( 3 )

    !CALL ConeFormulas( z_xx, z_xy, z_yy, nBdry, xs, tradial, ray2D( is )%x, BotTop )   ! special case of a conical seamount

    !!!! use kappa_xx or z_xx?
    ! kappa = ( z_xx * tradial( 1 ) ** 2 + 2 * z_xy * tradial( 1 ) * tradial( 2 ) + z_yy * tradial( 2 ) ** 2 )
    kappa = ( kappa_xx * tradial( 1 ) ** 2 + 2 * kappa_xy * tradial( 1 ) * tradial( 2 ) + kappa_yy * tradial( 2 ) ** 2 )

    IF ( BotTop == 'TOP' ) kappa = -kappa

    nBdry = nBdry / NORM2( nBdry )

    Th = DOT_PRODUCT( ray2D( is )%t, nBdry )  ! component of ray tangent normal to boundary

    tBdry = ray2D( is )%t - Th * nBdry        ! component of ray tangent along the boundary
    tBdry = tBdry / NORM2( tBdry )
    ! could also calculate tbdry as +/- of [ nbdry( 2), -nbdry( 1 ) ], but need sign

    Tg = DOT_PRODUCT( ray2D( is )%t, tBdry )  ! component of ray tangent along boundary

    ray2D( is1 )%NumTopBnc = ray2D( is )%NumTopBnc
    ray2D( is1 )%NumBotBnc = ray2D( is )%NumBotBnc
    ray2D( is1 )%x         = ray2D( is )%x
    ray2D( is1 )%t         = ray2D( is )%t - 2.0 * Th * nBdry  ! changing the ray direction

    ! Calculate the change in curvature
    ! Based on formulas given by Muller, Geoph. J. R.A.S., 79 (1984).

    CALL EvaluateSSP2D( ray2D( is1 )%x, c, cimag, gradc, crr, crz, czz, rho, xs, tradial, freq )

    ! incident and reflected (tilde) unit ray tangent and normal
    rayt       = c * ray2D( is  )%t                       ! unit tangent to ray
    rayt_tilde = c * ray2D( is1 )%t                       ! unit tangent to ray
    rayn       = +[ -rayt(       2 ), rayt(       1 ) ]   ! unit normal  to ray
    rayn_tilde = -[ -rayt_tilde( 2 ), rayt_tilde( 1 ) ]   ! unit normal  to ray

    RN = 2 * kappa / c ** 2 / Th    ! boundary curvature correction

    ! get the jumps (this could be simplified, e.g. jump in rayt is roughly 2 * Th * nbdry
    cnjump = -DOT_PRODUCT( gradc, rayn_tilde - rayn  )
    csjump = -DOT_PRODUCT( gradc, rayt_tilde - rayt )

    IF ( BotTop == 'TOP' ) THEN
       cnjump = -cnjump    ! flip sign for top reflection
       RN     = -RN
    END IF

    RM = Tg / Th   ! this is tan( alpha ) where alpha is the angle of incidence
    RN = RN + RM * ( 2 * cnjump - RM * csjump ) / c ** 2

    SELECT CASE ( Beam%Type( 2 : 2 ) )
    CASE ( 'D' )
       RN = 2.0 * RN
    CASE ( 'Z' )
       RN = 0.0
    END SELECT

    ray2D( is1 )%c   = c
    ray2D( is1 )%tau = ray2D( is )%tau
    ray2D( is1 )%p   = ray2D( is )%p + ray2D( is )%q * RN
    ray2D( is1 )%q   = ray2D( is )%q

    ! amplitude and phase change

    SELECT CASE ( HS%BC )
    CASE ( 'R' )                 ! rigid
       ray2D( is1 )%Amp   = ray2D( is )%Amp
       ray2D( is1 )%Phase = ray2D( is )%Phase
    CASE ( 'V' )                 ! vacuum
       ray2D( is1 )%Amp   = ray2D( is )%Amp
       ray2D( is1 )%Phase = ray2D( is )%Phase + pi
    CASE ( 'F' )                 ! file
       RInt%theta = RadDeg * ABS( ATAN2( Th, Tg ) )           ! angle of incidence (relative to normal to bathymetry)
       IF ( RInt%theta > 90 ) RInt%theta = 180. - RInt%theta  ! reflection coefficient is symmetric about 90 degrees
       CALL InterpolateReflectionCoefficient( RInt, RefC, Npts, PRTFile )
       ray2D( is1 )%Amp   = ray2D( is )%Amp   * RInt%R
       ray2D( is1 )%Phase = ray2D( is )%Phase + RInt%phi
    CASE ( 'A', 'G' )            ! half-space
       GK       = omega * Tg     ! wavenumber in direction parallel to bathymetry
       gamma1Sq = ( omega / c     ) ** 2 - GK ** 2 - i * tiny( omega )   ! tiny prevents g95 giving -zero, and wrong branch cut
       gamma2Sq = ( omega / HS%cP ) ** 2 - GK ** 2 - i * tiny( omega )
       gamma1   = SQRT( -gamma1Sq )
       gamma2   = SQRT( -gamma2Sq )

       Refl = ( HS%rho * gamma1 - rho * gamma2 ) / ( HS%rho * gamma1 + rho * gamma2 )

       IF ( ABS( Refl ) < 1.0E-5 ) THEN   ! kill a ray that has lost its energy in reflection
          ray2D( is1 )%Amp   = 0.0
          ray2D( is1 )%Phase = ray2D( is )%Phase
       ELSE
          ray2D( is1 )%Amp   = ABS( Refl ) * ray2D(  is )%Amp
          ray2D( is1 )%Phase = ray2D( is )%Phase + ATAN2( AIMAG( Refl ), REAL( Refl ) )

          ! compute beam-displacement Tindle, Eq. (14)
          ! needs a correction to beam-width as well ...
          !  IF ( REAL( gamma2Sq ) < 0.0 ) THEN
          !     rhoW   = 1.0   ! density of water
          !     rhoWSq  = rhoW  * rhoW
          !     rhoHSSq = rhoHS * rhoHS
          !     DELTA = 2 * GK * rhoW * rhoHS * ( gamma1Sq - gamma2Sq ) /
          ! &( gamma1 * i * gamma2 *
          ! &( -rhoWSq * gamma2Sq + rhoHSSq * gamma1Sq ) )
          !     RV( is + 1 ) = RV( is + 1 ) + DELTA
          !  END IF

          if ( Beam%Type( 4 : 4 ) == 'S' ) then   ! beam displacement & width change (Seongil's version)

             ch = ray2D( is )%c / conjg( HS%cP )
             co = ray2D( is )%t( 1 ) * ray2D( is )%c
             si = ray2D( is )%t( 2 ) * ray2D( is )%c
             ck = omega / ray2D( is )%c

             a   = 2 * HS%rho * ( 1 - ch * ch )
             b   = co * co - ch * ch
             d   = HS%rho * HS%rho * si * si + b
             sb  = sqrt( b )
             cco = co * co
             ssi = si * si

             delta   = a * co / si / ( ck * sb * d )
             pdelta  = real( delta ) / ( ray2D( is )%c / co)
             ddelta  = -a / ( ck*sb*d ) - a*cco / ssi / (ck*sb*d) + a*cco / (ck*b*sb*d) &
                  -a*co / si / (ck*sb*d*d) * (2* HS%rho * HS%rho *si*co-2*co*si)
             rddelta = -real( ddelta )
             sddelta = rddelta / abs( rddelta )

             print *, 'beam displacing ...'
             ray2D( is1 )%x( 1 ) = ray2D( is1 )%x( 1 ) + real( delta )   ! displacement
             ray2D( is1 )%tau    = ray2D( is1 )%tau + pdelta             ! phase change
             ray2D( is1 )%q      = ray2D( is1 )%q + sddelta * rddelta * si * c * ray2D( is )%p   ! beam-width change
          endif

       ENDIF
    END SELECT
  END SUBROUTINE Reflect2D

END MODULE ReflectMod


Real Function aknel(pkaon)
  Save
  If (pkaon<0.5 .Or. pkaon>=4.0) sigma1 = 0.
  If (pkaon>=0.5 .And. pkaon<1.0) sigma1 = 20.*pkaon**2.74
  If (pkaon>=1.0 .And. pkaon<4.0) sigma1 = 20.*pkaon**(-1.8)
  aknel = sigma1
  Return
End Function aknel


      subroutine splderiv(x,y,nd,n,u)
c Calculates the numerical derivative using spline interpolation
c Calls the Numerical Recipes routine TRIDIAG (double precision)
c REMARK
c End point behaviour is not so good
c INPUTS
c x(n),y(n) - arrays comprising x & y data (equispaced x)
c n - array size
c OUTPUT
c u(n) - first order derivative (dy/dx)
c
c P. Arumugam, IIT Roorkee - 07-June-2010
c
      implicit double precision (a-h,o-z)
      dimension x(nd),y(nd)
      dimension a(n),b(n),c(n),r(n),u(n)
      h=(x(n)-x(1))/dfloat(n-1)
      a(n)=1.d0
      b(1)=2.d0
      b(n)=2.d0
      c(n-1)=1.d0
      r(1)=3.d0*(y(2)-y(1))/h
      r(n)=3.d0*(y(n)-y(n-1))/h
      do i=2,n-1
        a(i)=1.d0
        b(i)=4.d0
        c(i-1)=1.d0
        r(i)=3.d0*(y(i+1)-y(i-1))/h
      end do
      call tridag(a,b,c,r,u,n)
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!!!!!!!residual for Laplace eqn!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine  block_Laplace(xloc,I_fluid,p_inter,w_inter,ien,lp_el,count_el,source)
  use global_constants
  use run_variables
  use fluid_variables
  implicit none

  integer ien(nen,ne)
  real(8) xloc(nsd,nn)
  real(8) I_fluid(nn)
  real(8) p_inter(nn)
  real(8) w_inter(nn)
!----------------------------
  integer count_el
  integer lp_el(count_el)
  real(8) source(nsd,nn)
!----------------------------
  real(8) x(nsd,nen),d(nen)
  real(8) eft0,det,effd,effm,effc
  real(8) sh(0:nsd,nen),ph(0:nsd,nen)
  real(8) xr(nsd,nsd),cf(nsd,nsd),sx(nsd,nsd)

  real(8) dr(nsd)

  integer inl,ie,isd,node,iq
!---------------------------------
  integer je
  real(8) local_source(nsd,nen)
  real(8) dg_l(nsd)
  real(8) divg
!==============================================================
  do je=1,count_el     !loop over elements
	ie=lp_el(je)
!   do ie=1,ne
     do inl=1,nen
	x(1:nsd,inl) = xloc(1:nsd,ien(inl,ie))
	d(inl) = I_fluid(ien(inl,ie))
	local_source(1:nsd,inl)=source(1:nsd,ien(inl,ie))
     end do

     do iq=1,nquad  ! loop over the quadrature points in each element
!!!!!!!!!!!!!!!!!!!!calculate shape function!!!!!!!!!!!!!!!!!!!!!!!!!!
	if (nsd==2) then
	   if(nen.eq.3) then
		include 'sh2d3n.h'
	   elseif(nen.eq.4) then
		include 'sh2d4n.h'
	   end if
	elseif(nsd==3) then
	   if(nen.eq.4) then
		include 'sh3d4n.h'
	   elseif(nen.eq.8) then
		include 'sh3d8n.h'
	   end if
	end if
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

     eft0 = abs(det)*wq(iq)   ! calculate weight at each quad point

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

     dr(:) = 0.0
     dg_l(:)=0.0

     do inl=1,nen
	dr(1:nsd) = dr(1:nsd)+sh(1:nsd,inl)*d(inl)
	dg_l(1:nsd) = dg_l(1:nsd)+sh(1:nsd,inl)*local_source(1:nsd,inl) ! dG/dx
     end do
	divg=sum(dg_l) ! div(G)

     ph(0:nsd,1:nen) = sh(0:nsd,1:nen)*eft0

     do inl=1,nen
	node=ien(inl,ie)
	do isd=1,nsd
	   p_inter(node)=p_inter(node)-ph(isd,inl)*dr(isd)+ph(0,inl)*divg
	end do! residual
	do isd=1,nsd
	   w_inter(node)=w_inter(node)+ph(isd,inl)*sh(isd,inl)
	end do! diag
     end do

     end do ! end of quad loop

  end do ! end of ele loop
!write(*,*)'w_inter=',w_inter(:)
end subroutine block_Laplace