! { dg-do run }

module e_50_4_mod
contains
  subroutine init (v1, v2, N)
    integer :: i, N
    real, pointer, dimension(:) :: v1, v2
    do i = 1, N
      v1(i) = i + 2.0
      v2(i) = i - 3.0
    end do
  end subroutine

  subroutine check (p, N)
    integer :: i, N
    real, parameter :: EPS = 0.00001
    real, pointer, dimension(:) :: p
    do i = 1, N
      diff = p(i) - (i + 2.0) * (i - 3.0)
      if (diff > EPS .or. -diff > EPS) call abort
    end do
  end subroutine

  subroutine vec_mult_1 (p, v1, v2, N)
    integer :: i, N
    real, pointer, dimension(:) :: p, v1, v2
    !$omp target map(to: v1(1:N), v2(:N)) map(from: p(1:N))
      !$omp parallel do
      do i = 1, N
        p(i) = v1(i) * v2(i)
      end do
    !$omp end target
  end subroutine

  subroutine vec_mult_2 (p, v1, v2, N)
    real, dimension(*) :: p, v1, v2
    integer :: i, N
    !$omp target map(to: v1(1:N), v2(:N)) map(from: p(1:N))
      !$omp parallel do
      do i = 1, N
        p(i) = v1(i) * v2(i)
      end do
    !$omp end target
  end subroutine
end module

program e_50_4
  use e_50_4_mod, only : init, check, vec_mult_1, vec_mult_2
  real, pointer, dimension(:) :: p1, p2, v1, v2
  integer :: n
  n = 1000
  allocate (p1(n), p2(n), v1(n), v2(n))
  call init (v1, v2, n)
  call vec_mult_1 (p1, v1, v2, n)
  call vec_mult_2 (p2, v1, v2, n)
  call check (p1, N)
  call check (p2, N)
  deallocate (p1, p2, v1, v2)
end program


program ch0901
    ! Twelve Times Table
    implicit none

    integer :: t

    print *, ' '
    print *, ' Twelve times table'
    print *, ' '
    do t = 1, 12
        print 100, t, t*12
    end do

100 format (' ', i3, ' * 12 = ', i3)
end program


subroutine flr_i

!*****************************************************************!
! COMPUTE: ions' gyroviscous tensor G                             !
!          [2D version, assumes B "mainly" along z: Bperp << Bz]  !
! --------------------------------------------------------------- !
! S. S. Cerri, 2011                                               !
!                                                                 !
!                                                                 !
!                       Gi_ij  i,j=x,y,z                          !
!                                                                 !
! N.B.: Gi_ij is a SYMMETRIC tensor with ZERO TRACE, so one needs !
!       only 5 linear independent components instead of the whole !
!       9 components of the tensor:                               !
!                                                                 !
!         i.e., Gi_xx, Gi_zz, Gi_xy, Gi_xz, and Gi_yz             !
!                                                                 !
!       Moreover, we consider a coordinate system such that the   !
!       z-axis is aligned with the mean magnetic field <B>, i.e.  !
!                                                                 !
!                  Gi_zz = 0  and  Gi_xx = -Gi_yy                 !
!                                                                 !
!    for further details, see:                                    !
!                                                                 !
!    *** Cerri et al., Phys. Plasmas 20, 112112 (2013) ***        !
!                                                                 !
!*****************************************************************!

use parameter_mod
use box_mod
use deriv_mod
use fields_UJ_mod
use fields_DP_mod
use fields_EB_mod
use dom_distr_mod
use parallel_mod

implicit none

integer :: ix, iy, iz

real(dp), allocatable :: dxui_j(:), dyui_j(:), dzui_j(:)
real(dp), allocatable :: Ut(:,:,:)

allocate(dxui_j(nx))
allocate(dyui_j(ny))
allocate(dzui_j(nz))
allocate( Ut( nx, nyt, nz ) )  ! nyt ~ ny/nproc

!------------------------------------------------------!
!  Compute:  Gi_xx = - Gi_yy                           !
!                                                      !
!  Gi_xx = -0.5*(pi_perp/|B|)*[d(Uix)/dy + d(Uiy)/dx]  !
!                                                      !
!------------------------------------------------------!

call traspdist( Uiy, Ut, 1 )
do iz = 1, nz
  do iy = 1, nyt
    call derx_1( Ut(:,iy, iz), dxui_j )
    Ut(:,iy, iz) = dxui_j
  enddo
enddo
call traspdist( Gi_xx, Ut, -1 )

do iz = 1, nz
  do ix = 1, nxl
    call dery_1( Uix(ix,:,iz), dyui_j)
    Gi_xx(ix,:,iz) = - 0.5d0 * pi_perp(ix,:,iz) * ( Gi_xx(ix,:,iz) + dyui_j )
  enddo
enddo

Gi_xx = Gi_xx / dsqrt(B00)

!------------------------------------------------------!
!  Compute:  Gi_xy = Gi_yx                             !
!                                                      !
!  Gi_xy = -0.5*(pi_perp/|B|)*[d(Uiy)/dy - d(Uix)/dx]  !
!                                                      !
!------------------------------------------------------!

call traspdist( Uix, Ut, 1 )
do iz = 1, nz
  do iy = 1, nyt
    call derx_1( Ut(:,iy, iz), dxui_j )
    Ut(:,iy, iz) = dxui_j
  enddo
enddo
call traspdist( Gi_xy, Ut, -1 )

do iz = 1, nz
  do ix = 1, nxl
    call dery_1( Uiy(ix,:,iz), dyui_j)
    Gi_xy(ix,:,iz) = 0.5d0 * pi_perp(ix,:,iz) * (Gi_xy(ix,:,iz) - dyui_j)
  enddo
enddo

Gi_xy = Gi_xy / dsqrt(B00)

!--------------------------------------------------!
!  Compute:  Gi_xz = Gi_zx                         !
!                                                  !
!  Gi_xz = -2.0*(pi_para/|B|)*d(Uiy)/dz            !
!         - (pi_perp/|B|)*[d(Uiz)/dy - d(Uiy)/dz]  !
!                                                  !
! [ 2D version: Gi_xz = -(pi_perp/|B|)*d(Uiz)/dy ] !
!--------------------------------------------------!

do iz = 1, nz
  do ix = 1, nxl
    call dery_1( Uiz(ix,:,iz), dyui_j)
    Gi_xz(ix,:,iz) = -pi_perp(ix,:,iz)*dyui_j
  enddo
enddo

Gi_xz = Gi_xz / dsqrt(B00)

!--------------------------------------------------!
!  Compute:  Gi_yz = Gi_zy                         !
!                                                  !
!  Gi_yz = 2.0*(pi_para/|B|)*d(Uix)/dz             !
!         + (pi_perp/|B|)*[d(Uiz)/dx - d(Uix)/dz]  !
!                                                  !
! [ 2D version: Gi_yz = (pi_perp/|B|)*d(Uiz)/dx ]  !
!--------------------------------------------------!

call traspdist( Uiz, Ut, 1 )
do iz = 1, nz
  do iy = 1, nyt
    call derx_1( Ut(:,iy, iz), dxui_j )
    Ut(:,iy, iz) = dxui_j
  enddo
enddo
call traspdist( Gi_yz, Ut, -1 )

Gi_yz = pi_perp * Gi_yz
Gi_yz = Gi_yz / dsqrt(B00)

!----------------------------------------------------!
! *** taking care of "omega*B" asymmetry ***         !
!  (arises from sign of Omega_ci)                    !
!                                                    !
! see: Cerri et al., Phys. Plasmas 20, 112112 (2013) !
!----------------------------------------------------!
do iz = 1, nz
  do iy = 1, nyl
    do ix = 1, nxl
      if (Bz(ix,iy,iz) < 0.0) then
        Gi_xx(ix,iy,iz) = - Gi_xx(ix,iy,iz)
        Gi_xy(ix,iy,iz) = - Gi_xy(ix,iy,iz)
        Gi_xz(ix,iy,iz) = - Gi_xz(ix,iy,iz)
        Gi_yz(ix,iy,iz) = - Gi_yz(ix,iy,iz)
      endif
    enddo
  enddo
enddo

!-------------------------------------------------------!
! smoothing -> no gyroviscous terms at the x-boundaries !
!-------------------------------------------------------!
do ix = 1, nxl
  Gi_xx(ix,:,:) = lambda(ixlg + ix - 1) * Gi_xx(ix,:,:)
  Gi_xy(ix,:,:) = lambda(ixlg + ix - 1) * Gi_xy(ix,:,:)
  Gi_xz(ix,:,:) = lambda(ixlg + ix - 1) * Gi_xz(ix,:,:)
  Gi_yz(ix,:,:) = lambda(ixlg + ix - 1) * Gi_yz(ix,:,:)
enddo

deallocate(dxui_j)
deallocate(dyui_j)
deallocate(dzui_j)
deallocate(Ut)

end subroutine


      double complex function F31m(s)
      implicit none
      include 'epinv.f'
      include 'scale.f'
      double precision s
c      double complex qlI3
      double complex lnrat
c      integer ep
c      F31m=czip
c      do ep=-2,0
c      F31m=F31m+s*epinv**(-ep)*qlI3(0d0,0d0,s,0d0,0d0,0d0,musq,ep)
c      enddo

c--- NOTE: checked on 8/31/09 that this agrees with the expression above
      F31m=epinv**2-epinv*lnrat(-s,musq)+0.5d0*lnrat(-s,musq)**2

      return
      end


      SUBROUTINE DT_BEAMPR(What,Plab,Mode)

C***********************************************************************
C Initialization of event generation                                   *
C This version dated  7.4.98  is written by S. Roesler.                *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION anorf , bge , bgx , bgy , bgz , BOG , cod , cof ,
     &                 e1 , e2 , ecm , elab , ONE , p1cms , p1tot ,
     &                 p2cms , p2tot , pecms , ph , Plab
      DOUBLE PRECISION pp1 , pp2 , ppt , ptot , pxcms , pycms , pzcms ,
     &                 sid , sif , th , TINY10 , TWOPI , What , ZERO
      INTEGER i , Mode
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
      PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)

      LOGICAL lbeam

C event history

      INCLUDE 'inc/dtevt1'
C extended event history
      INCLUDE 'inc/dtevt2'
C properties of interacting particles
      INCLUDE 'inc/dtprta'
C particle properties (BAMJET index convention)
      INCLUDE 'inc/dtpart'
C beam momenta
      INCLUDE 'inc/dtbeam'

C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
      DIMENSION What(6) , p1cms(4) , p2cms(4)

      DATA lbeam/.FALSE./

      IF ( Mode.EQ.2 ) THEN

         IF ( lbeam ) THEN
            IF ( (NPOint(4).EQ.0) .OR. (NHKk.LT.NPOint(4)) ) RETURN
            DO i = NPOint(4) , NHKk
               IF ( (ABS(ISThkk(i)).EQ.1) .OR. (ISThkk(i).EQ.1000) .OR.
     &              (ISThkk(i).EQ.1001) ) THEN
                  CALL DT_MYTRAN(1,PHKk(1,i),PHKk(2,i),PHKk(3,i),cod,
     &               sid,cof,sif,pxcms,pycms,pzcms)
                  pecms = PHKk(4,i)
                  CALL DT_DALTRA(bge,bgx,bgy,bgz,pxcms,pycms,pzcms,
     &               pecms,ptot,PHKk(1,i),PHKk(2,i),PHKk(3,i),PHKk(4,i))
               END IF
            END DO
         ELSE
            Mode = -1
         END IF
         GOTO 99999
      END IF

      e1 = What(1)
      IF ( e1.LT.ZERO ) e1 = DBLE(IPZ)/DBLE(IP)*ABS(What(1))
      e2 = What(2)
      IF ( e2.LT.ZERO ) e2 = DBLE(ITZ)/DBLE(IT)*ABS(What(2))
      pp1 = SQRT((e1+AAM(IJProj))*(e1-AAM(IJProj)))
      pp2 = SQRT((e2+AAM(IJTarg))*(e2-AAM(IJTarg)))
      th = 1.D-6*What(3)/2.D0
      ph = What(4)*BOG
      P1(1) = pp1*SIN(th)*COS(ph)
      P1(2) = pp1*SIN(th)*SIN(ph)
      P1(3) = pp1*COS(th)
      P1(4) = e1
      P2(1) = pp2*SIN(th)*COS(ph)
      P2(2) = pp2*SIN(th)*SIN(ph)
      P2(3) = -pp2*COS(th)
      P2(4) = e2
      ecm = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))
     &      **2-(P1(3)+P2(3))**2)
      elab = (ecm**2-AAM(IJProj)**2-AAM(IJTarg)**2)/(2.0D0*AAM(IJTarg))
      Plab = SQRT((elab+AAM(IJProj))*(elab-AAM(IJProj)))
      bgx = (P1(1)+P2(1))/ecm
      bgy = (P1(2)+P2(2))/ecm
      bgz = (P1(3)+P2(3))/ecm
      bge = (P1(4)+P2(4))/ecm
      CALL DT_DALTRA(bge,-bgx,-bgy,-bgz,P1(1),P1(2),P1(3),P1(4),p1tot,
     &               p1cms(1),p1cms(2),p1cms(3),p1cms(4))
      CALL DT_DALTRA(bge,-bgx,-bgy,-bgz,P2(1),P2(2),P2(3),P2(4),p2tot,
     &               p2cms(1),p2cms(2),p2cms(3),p2cms(4))
      cod = p1cms(3)/p1tot
C     SID = SQRT((ONE-COD)*(ONE+COD))
      ppt = SQRT(p1cms(1)**2+p1cms(2)**2)
      sid = ppt/p1tot
      cof = ONE
      sif = ZERO
      IF ( p1tot*sid.GT.TINY10 ) THEN
         cof = p1cms(1)/(sid*p1tot)
         sif = p1cms(2)/(sid*p1tot)
         anorf = SQRT(cof*cof+sif*sif)
         cof = cof/anorf
         sif = sif/anorf
      END IF
C*check
C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
C     PAX = ZERO
C     PAY = ZERO
C     PAZ = P1TOT
C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
C     PBX = ZERO
C     PBY = ZERO
C     PBZ = -P2TOT
C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
C    &            P1CMS(1),P1CMS(2),P1CMS(3))
C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
C    &            P2CMS(1),P2CMS(2),P2CMS(3))
C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
C     STOP
C*

      lbeam = .TRUE.

99999 END SUBROUTINE


module globals

    use iso_fortran_env, only: r64 => real64
    use slf_cgs

    implicit none !--------------------------------------------------------!

    real(r64), parameter, private :: X0 = 0.68d0 / cgs_kapes_hydrogen - 1
    ! real(r64), parameter, private :: X0 = 0.7381
    real(r64), parameter, private :: Z0 = 0.0134

    real(r64) :: abuX = X0
    real(r64) :: abuZ = Z0

    real(r64) :: kappa_es = cgs_kapes_hydrogen * (1 + X0) / 2
    real(r64) :: kappa_ff_0 = 3.68d22 * (1 - Z0) * (1 + X0)
    real(r64) :: kappa_bf_0 = 4.34d25 * Z0 * (1 + X0)
    real(r64) :: kappa_abs_0 = 3.68d22 * (1 - Z0) * (1 + X0)

    logical :: use_opacity_ff = .true.
    logical :: use_opacity_bf = .false.
    logical :: use_opacity_planck = .true.
    logical :: use_conduction = .false.

    real(r64) :: mbh, mdot, rschw

    real(r64) :: cndredu = 1e-1

    real(r64), parameter :: miu = 0.50
    real(r64), parameter :: pi = 4*atan(real(1,r64))

    !   którego równania użyc?
    character, parameter :: EQUATION_DIFFUSION = 'D', &
          EQUATION_BALANCE = 'C', EQUATION_COMPTON = 'W'
    character :: cfg_temperature_method = EQUATION_DIFFUSION

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

    elemental subroutine cylinder(mbh, mdot, r, rschw, omega, facc, teff, zscale)
        real(r64), intent(in) :: mbh, mdot, r
        real(r64), intent(out) :: rschw, omega, facc, teff, zscale
        real(r64) :: GM, mdot_crit, mdot_edd

        GM = cgs_graw * mbh * sol_mass

        rschw = 2 * GM / cgs_c**2
        omega = sqrt( GM / (r * rschw)**3 )

        mdot_crit = 4 * pi * GM / (cgs_c * cgs_kapes)
        mdot_edd = 12 * mdot_crit
        facc = 3 * GM * (mdot * mdot_edd) / (8 * pi * (r * rschw)**3) &
        &    * (1 - sqrt(3/r))

        teff = ( facc / cgs_stef ) ** (1d0 / 4d0)
        zscale = sqrt( 2 * cgs_k_over_mh * teff ) / omega
    end subroutine

    elemental function fzscale(mbh, mdot, r) result(zscale)
        real(r64), intent(in) :: mbh, mdot, r
        real(r64) :: omega, facc, teff, zscale, rschw
        call cylinder(mbh, mdot, r, rschw, omega, facc, teff, zscale)
    end function

    elemental function fTeff(mbh, mdot, r) result(teff)
      real(r64), intent(in) :: mbh, mdot, r
      real(r64) :: omega, facc, teff, zscale, rschw
      call cylinder(mbh, mdot, r, rschw, omega, facc, teff, zscale)
    end function

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

    elemental function kapabs0(X, Z) result(kab0)
        real(r64), intent(in) :: X, Z
        real(r64) :: kab0, kff0, kbf0
        kff0 = 3.68d22 * (1 - Z) * (1 + X)
        kbf0 = 4.34d25 * Z * (1 + X)
        kab0 = merge(kff0, 0.0_r64, use_opacity_ff)   &
             + merge(kbf0, 0.0_r64, use_opacity_bf)
    end function

    elemental function kapabp0(X, Z) result(kab0)
        real(r64), intent(in) :: X, Z
        real(r64) :: kab0
        kab0 = kapabs0(X, Z) * merge(37, 1, use_opacity_planck)
    end function

    elemental function kapes0(X, Z) result(kes0)
        real(r64), intent(in) :: X, Z
        real(r64) :: kes0
        kes0 = cgs_kapes_hydrogen * (1 + X) / 2 + 0*Z
    end function

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

    elemental function fksct(rho,T) result(ksct)
        real(r64), intent(in) :: rho,T
        real(r64):: ksct0, ksct !, red
        ksct0 = kapes0(abuX,abuZ)
        ! red = 1d0 / (( 1 + 2.7e11 * rho / T**2 ) * ( 1 + (T / 4.5e8)**0.86 ))
        ksct = ksct0 ! * red
    end function

    elemental subroutine KAPPSCT(rho,T,ksct,krho,kT)
        real(r64), intent(in) :: rho,T
        real(r64), intent(out) :: ksct,krho,kT
        real(r64):: ksct0 !, red, redrho, redT
        ksct0 = kapes0(abuX,abuZ)
        ! red = 1d0 / (( 1 + 2.7e11 * rho / T**2 ) * ( 1 + (T / 4.5e8)**0.86 ))
        ksct = ksct0 ! * red
        !redrho = -2.7d+11/(T**2*(1.0d0 + 2.7d+11*rho/T**2)**2 &
        !    *(3.616073d-8*T**0.86d0 + 1.0d0))
        krho = 0 ! ksct0 * redrho
        !redT = -3.109823d-8*T**(-0.14d0)/((1.0d0 + 2.7d+11*rho/T**2)*( &
        !    3.616073d-8*T**0.86d0 + 1.0d0)**2) + 5.4d+11*rho/(T**3*(1.0d0 + &
        !    2.7d+11*rho/T**2)**2*(3.616073d-8*T**0.86d0 + 1.0d0))
        kT = 0 ! ksct0 * redT
    end subroutine

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

    elemental function fkabs(rho,T) result(kabs)
        real(r64), intent(in) :: rho,T
        real(r64) :: kabs
        kabs = kapabs0(abuX,abuZ) * rho * T ** (-7d0/2d0)
    end function

    elemental subroutine kappabs(rho,T,kap,krho,kT)
        use ieee_arithmetic, only: ieee_is_nan
        real(r64), intent(in) :: rho,T
        real(r64), intent(out) :: kap,krho,kT

        kap = kapabs0(abuX,abuZ) * rho * T ** (-7d0/2d0)
        krho = kap / rho
        kT = (-7d0/2d0) * kap / T
    end subroutine

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

    elemental function fkabp(rho,T) result(kabs)
        real(r64), intent(in) :: rho,T
        real(r64) :: kabs
        kabs = kapabp0(abuX,abuZ) * rho * T ** (-7d0/2d0)
    end function

    elemental subroutine kappabp(rho,T,kap,krho,kT)
        use ieee_arithmetic, only: ieee_is_nan
        real(r64), intent(in) :: rho,T
        real(r64), intent(out) :: kap,krho,kT

        kap = kapabp0(abuX,abuZ) * rho * T ** (-7d0/2d0)
        krho = kap / rho
        kT = (-7d0/2d0) * kap / T
    end subroutine

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

    elemental function fkcnd(rho,T) result(kcnd)
      real(r64), intent(in) :: rho,T
      real(r64) :: kcnd
      kcnd = 5.6d-7 * cndredu * T**2.5d0
    end function

    elemental subroutine kappcnd(rho,T,kap,krho,kT)
      use ieee_arithmetic, only: ieee_is_nan
      real(r64), intent(in) :: rho,T
      real(r64), intent(out) :: kap,krho,kT

      kap = 5.6d-7 * cndredu * T**2.5d0
      krho = 0
      kT = 2.5d0 * kap / T
    end subroutine

end module


      SUBROUTINE NMOED(BUF,LBUF, ibuf, nmonum )
C                             PROCESS NMO, NMO2
C                             ------- ---  ----
C
C  DOCUMENT DATE:
C
c     NMO applies a travel-time correction to each trace.  The following
c  corrections are available:
c  1)  Normal MoveOut or NMO: T(0) = SQRT(T(X)**2 - X**2/V(T)**2)
c  2)  MoveIn or denmo: T(X) = SQRT(T(0)**2 + X**2/V(T)**2)
c  3)  Slant MoveOut or SMO:  T(0) = T(X) + X/V
c  4)  XMO - Move out to range X (AMO? - Abnormal MoveOut)
c            NMO followed by MoveIn
c  5)  NMO with interval velocities
c     Process NMO2 is identical to PROCESS NMO, enabling NMO to be given
c  twice in a job.
C     IN SOLVING NMO, THE RANGE X IS IN TRACE HEADER AND THE VELOCITY MUST BE
C  SPECIFIED BY THE USER.  IT IS USUALLY THOUGHT THAT ALL TRACES COMMON TO THE
C  SAME REFLECTION POINT SHOULD HAVE THE SAME VELOCITY FUNCTION.  THUS, THE
C  VELOCITY FUNCTION GIVEN BY THE USER MAY BE SPECIFIED AT VARIOUS POINTS ALONG
C  THE SEISMIC LINE (CONTROL POINTS).  TRACES LYING BETWEEN THE USER SPECIFIED
C  CONTROL POINTS ARE OBTAINED THROUGH INTERPOLATION OF THE ADJACENT SPECIFIED
C  VELOCITY FUNCTIONS.  THE TIMES ASSOCIATED WITH THE VELOCITY FUNCTION MAY BE
C  RELATIVE TO THE WATER BOTTOM IF SPECIFIED BY THE USER, BUT ARE RELATIVE
C  TO TIME ZERO OTHERWISE.
C     TIMES NOT SPECIFIED SPECIFICALLY IN A VELOCITY FUNCTION HAVE A VELOCITY
C  OBTAINED THROUGH LINEAR INTERPOLATION.  THE SPATIAL VARIATION OF VELOCITY
C  FUNCTIONS IS PERFORMED THROUGH LINEAR INTERPOLATION ALONG ISO-VELOCITY
C  LINES.  E.G. IF RP 1 HAS VTP 1500 0. 2000 .4 2500 1.0 AND RP 3 HAS
C  VTP 1500 0. 2000 .6 2500 1.0, THEN RP 2 WILL GET VTP 1500 0. 2000 .5 2500 1.
C     VELOCITY CONTROL POINTS ARE DEFINED AS EITHER SHOT POINT NUMBERS OR RP
C  NUMBERS. EACH PARAMETER LIST HAS A START AND END CONTROL POINT WITH THE
C  PARAMETERS BEING CONSTANT FOR ALL POINTS BETWEEN THE FIRST AND LAST CONTROL
C  POINT OF THE LIST.  E.G.  IF THE FIRST CONTROL POINT=100 AND THE LAST CONTROL
C  POINT=110, THE POINTS 101 TO 109 WILL ALSO HAVE THE SAME PARAMETERS APPLIED.
C     SPATIAL VARIATION IS BY SHOT IF THE DATA IS SORTED BY SHOT AND IS
C  VARIED BY RP IF THE DATA IS SORTED BY RP. SEE VARIABLE VTRKWB FOR VARIATION
C  USING WATER DEPTH, A USEFUL OPTION DURING SHIPBOARD PROCESSING.
C  *** NOTE ***  SPATIAL VARIATION OF VELOCITIES WITH VELOCITY INVERSIONS HAS
C                PROBLEMS!!!!
C     EACH PARAMETER LIST MUST BE TERMINATED WITH THE WORD END.  THE ENTIRE SET
C  OF NMO PARAMETERS MUST BE TERMINATED BY THE WORD END.
C
C  THE PARAMETER DICTIONARY
C  --- --------- ----------
C  FNO    - THE FIRST SHOT (OR RP) TO APPLY THE VELOCITIES TO.  SHOT (RP) NUMBERS
C           MUST INCREASE MONOTONICALLY.
C           PRESET=1
C  LNO    - THE LAST SHOT (RP) NUMBER TO APPLY THE VELOCITIES TO.  LNO MUST BE
C           LARGER THAN FNO IN EACH LIST AND MUST INCREASE LIST TO LIST.
C           DEFAULT=FNO
C  VTP    - VELOCITY-TIME-PAIRS.  A LIST OF STACKING VELOCITY AND TWO-WAY
C           TRAVEL TIME (IN SECONDS) PAIRS.  VTP MUST BE GIVEN IN EACH NMO
C           PARAMETER LIST.  A MAXIMUM OF 25 PAIRS MAY BE GIVEN.  DATA TIMES
C           BEFORE THE FIRST GIVEN TIME IN VTP ARE HELD CONSTANT FROM THE FIRST
C           GIVEN TIME.  LIKEWISE, DATA TIMES EXCEEDING THE LAST GIVEN TIME IN
C           VTP ARE HELD CONSTANT FROM THE LAST GIVEN VTP TIME.
C           DEFAULT=NONE. E.G. VTP 1490 1.0 2000 2.0
C  STRETC - THE AMOUNT OF STRETCH (NMO OR DELTA T), IN SECONDS, PERMISSIBLE.
C           DATA EXCEEDING STRETCH WILL BE MUTED BY PROCESS NMO.  Valid
c           with NMO (type 1) only.
C           PRESET =1.
C  ADDWB  - WHEN GIVEN A VALUE OF YES, THE WATER BOTTOM TIME IS ADDED TO THE
C           VELOCITY FUNCTION AFTER VARIATION HAS BEEN DONE.
C           PRESET=NO
c  TYPE   - The type of travel time correction to apply.
c         =1,  Normal MoveOut or NMO: T(0) = SQRT(T(X)**2 - X**2/V(T)**2)
c         =2,  MoveIn or denmo: T(X) = SQRT(T(0)**2 + X**2/V(T)**2)
c         =3,  Slant MoveOut or SMO:  T(0) = T(X) + X/V
c         =4,  XMO
c         =5,  NMO with interval velocities
c           PRESET = 1            e.g. type 2
c  VINTPL - The type of velocity interpolation between successive velocity
c           control points.
c         = 1  Velocity spatial interpolation according to "iso-velocity"
c         = 2  Allows regions of constant velocity to be interpolated
c              correctly, however vtp pairs must be equal across control
c              points.
c           Preset = 1
c  VTRKWB - Velocity Tracking Waterbottom.  When given a positive value,
c           velocity interpolation is cued from the water depth as defined
c           in the SEGY header, word buf(54). This is typically the center-
c           beam depth value which is placed in the header during acquistion
c           for each individual shot.  The value of VTRKWB represents a
c           disallowable jump in centerbeam depth, from one gather, shot or
c           cdp, to the next. If a disallowable jump in centerbeam depth
c           occurs, the centerbeam depth from the previous gather is used.
c           Although each trace in a gather may have a different centerbeam
c           depth values, the depth value from first trace will be applied
c           to the entire gather to minimize static shift problems. This
c           option is useful during realtime shipboard processing and allows
c           a pre-defined 2-D velocity field to be used during processing,
c           with fno and lno values representing water depth, vtp pairs
c           defining the stacking velocity function for a given water depth.
c           This scheme allows more flexibility for varying velocities along
c           a reflection line (as opposed to hanging a single velocity
c           function from seafloor).
c           Preset = -9999.0      e.g. vtrkwb 100.0
c
C  END    - TERMINATES EACH PARAMETER LIST.
C
C
C  WRITTEN AND COPYRIGHTED BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, APRIL 1980
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
C
C
c  mod Nov 1991 by gmk to add VINTPL
c  mod May 1995 to add NMO2
c  mod Nov 1995 by gmk to add vtrkwb
c  mod 21 May 1997 - Add parameter VMUL
c  mod 21 Jul 97 - Add parameter VADD
c                - Allow process NMO3
c  mod 11 Nov 97 - ADD OPATH for writing the velocities out
c  mod 2 March 98 - Initialize on the first call to nmoed when more than
c                 one nmo given (nmo2, nmo3)
c  mod 12 Mar 98 - Write the SEGY header to OPATH on first list only.
c  mod 16 Mar 98 - Allow vintpl 3
c  mod 2 Nov 98 - Added XMO (parameter NEWX)
c  mod 18 Jan 00 - Insist velocities within each VTP monotonically increase.
c  mod 17 Jul 02 - Make maxdt equivalent to stretc
c                - Add parameters dstretch and maxdt (old stretc)
c  mod 10 Mar 03 - Add parameter IVTP - Interval VTP
c  mod 11 Apr 03 - Change vintpl preset for IVTP (vintpl=4).
c  mod 30 Sep 08 - Add parameter xfactor
c  mod 27 Jun 11 - Add parameter HIRES
c  mod 5 Jul 12 - Allow non-increasing velocities on VINTPL 2
c  mod 16 Jul 12 - Make HIRES a yes/no switch as well as 1/0.
c  mod 18 Jul 18 - Swap the trace header when writing a segy OPATH
c                - populate the binary header since some other system demand some entries.
c
C  ARGUMENTS:
C  BUF    - A SCRATCH ARRAY AT LEAST 60 32BIT WORDS LONG.
C  LBUF   - THE SAME ARRAY BUT USED FOR LONG INTEGERS.  PRIME DOESN'T ALLOW
C           EQUIVALENCING OF ARGUMENTS.
C
C  DISC PARAMETER LIST ORDER:
C  WORD 1)  FNO      (ALL ENTRIES ARE 32 BITS LONG)
C       2   LNO
C       3)  STRETC
C       4)  ITYPE
C       5)  ADDWB
C       6)  LPRINT
C       7)  VINTPL
C       8)  VTRKWB
c       11) lunvtp
c       12) newx
c       14) dstretch
c       16) xfactor
c       17) hires
C       npars)  NS  - THE NUMBER OF ENTRIES IN THE VTP GIVEN BY THE USER
C       18-68) VTP  - ALWAYS 50 LONG
C
C
C
      PARAMETER (NPARS=18)                                              ! THE NUMBER OF USER PARAMETERS
      PARAMETER (MAXVTP=50)                                             ! THE MAXIMUM NUMBER OF VTPS THAT NMOEX CAN HANDLE
      PARAMETER (NWRDS=MAXVTP+NPARS)
      PARAMETER (MULTIV=NPARS)                                        ! THE INDEX OF THE FIRST MULTIVALUED PARAMETER
c**** (That means vtp must be the last parameter)
      CHARACTER*8 NAMES(NPARS)
      CHARACTER*1 TYPES(NPARS)
      DIMENSION LENGTH(NPARS)
      CHARACTER*80 TOKEN, ctemp
      DIMENSION VALS(NPARS),LVALS(NPARS)
      COMMON /EDITS/ IERROR,IWARN,IRUN,NOW,ICOMPT
      COMMON /readt/ itunit, numhdr, numdat, ihunit
      EQUIVALENCE (VALS(1),LVALS(1))
      COMMON /NMOCOM/ NUNIT(3), NLISTS(3), nsegyfile(3)
      DIMENSION BUF(111),LBUF(111)
      INTEGER*2 ibuf(200)
      INTEGER FNO
      INTEGER VINTPL
      REAL VTRKWB, maxdt
      LOGICAL iexist, first
C
C
      EQUIVALENCE (FNO,LVALS(1)),
     2            (LNO,LVALS(2)),
     3            (ADDWB,LVALS(3)),
     4            (LPRINT,LVALS(4)),
     5            (STRETC,VALS(5)),
     6            (ITYPE,LVALS(6)),
     7            (VINTPL,LVALS(7)),
     8            (VTRKWB,VALS(8)),
     9            (vmul,vals(9)),
     *            (vadd,vals(10)),
     1            (opath,vals(11)),
     2            (newx,lvals(12)),
     3            (maxdt,lvals(13)),
     4            (dstretch,vals(14)),
     6            (xfactor,vals(16)),
     7            (hires,vals(17)),
     *            (VTP,VALS(NPARS))
      DATA NAMES/'FNO   ','LNO   ','ADDWB ','LPRINT','STRETC',
     *           'TYPE  ','VINTPL','VTRKWB','VMUL  ','VADD  ',
     &           'OPATH ','NEWX  ','MAXDT','DSTRETCH','IVTP  ',
     &           'XFACTOR','HIRES ',
     &           'VTP   '/
      DATA LENGTH/3,3,5,6,6,4,6,6,2*4,5,4,5,8,4,7,5,3/
      DATA TYPES/'L','L','A','L','F','L','L',3*'F','A','L',4*'F',
     &           'A','F'/
      DATA first/.TRUE./
      SAVE first
C****
C****      SET THE PRESETS
C****
      FNO=1
      LNO=32768
      VTP=-1.
      STRETC=1.
      ITYPE=0
      IADDWB=0
      LPRINT=0
      VINTPL = 99999
      VTRKWB = -9999.0
      IF( first ) THEN
          first = .FALSE.
          DO i = 1, 3
             nunit(i) = 0
             nlists(i) = 0
             nsegyfile(i) = 0
          ENDDO
      ENDIF
      LLNO=0
      NS=0
      nvtps = 0
      vmul = 1.
      vadd = 0.
      lunvtp = 0
      newx = -123456
      maxdt = 0.
      dstretch = 0.
      xfactor = 1.
      hires = 0.
C****
C0****    GET A PARAMETER FILE
C****
      CALL GETFIL(1,NUNIT(nmonum),token,ISTAT)
C****
C****   THE CURRENT COMMAND LINE IN THE SYSTEM BUFFER MAY HAVE THE PARAMETERS.
C****   GET A PARAMETER LIST FROM THE USER.
C****
C****
C****   THE CURRENT COMMAND LINE IN THE SYSTEM BUFFER MAY HAVE THE PARAMETERS.
C****   GET A PARAMETER LIST FROM THE USER.
C****
      NTOKES=1
  100 CONTINUE
      CALL GETOKE(TOKEN,NCHARS)                                         ! GET A TOKEN FROM THE USER PARAMETER LINE
      CALL UPCASE(TOKEN,NCHARS)                                         ! CONVERT THE TOKEN TO UPPERCASE
      IF(NCHARS.GT.0) GO TO 150
      IF(NOW.EQ.1) PRINT 140
  140 FORMAT(' <  ENTER PARAMETERS  >')
      CALL RDLINE                                                       ! GET ANOTHER USER PARAMETER LINE
      NTOKES=0
      GO TO 100
  150 CONTINUE
      NTOKES=NTOKES+1
      DO 190 I=1,NPARS                                                  ! SEE IF IT IS A PARAMETER NAME
      LEN=LENGTH(I)                                                     ! GET THE LEGAL PARAMETER NAME LENGTH
      IPARAM=I                                                          ! SAVE THE INDEX
      IF(TOKEN(1:NCHARS).EQ.NAMES(I)(1:LEN).AND.NCHARS.EQ.LEN) GO TO 200
  190 CONTINUE                                                          ! STILL LOOKING FOR THE NAME
      IF(TOKEN(1:NCHARS).EQ.'END'.AND.NCHARS.EQ.3) GO TO 1000           ! END OF PARAM LIST?
      IF(NS.NE.0) GO TO 230
      PRINT 191, TOKEN(1:NCHARS)
  191 FORMAT(' ***  ERROR  *** NMO DOES NOT HAVE A PARAMETER ',
     *  'NAMED ',A10)
      IERROR=IERROR+1
      GO TO 100
C****
C****    FOUND THE PARAMETER NAME, NOW FIND THE VALUE
C****
  200 CONTINUE
      NPARAM=IPARAM
  210 CONTINUE                                                          !  NOW FIND THE VALUE
      CALL GETOKE(TOKEN,NCHARS)
      NTOKES=NTOKES+1
      IF(NCHARS.GT.0) GO TO 230                                         ! END OF LINE?
      IF(NOW.EQ.1) PRINT 140                                            ! THIS ALLOWS A PARAMETER TO BE ON A DIFFERENT LINE FROM THE NAME
      CALL RDLINE                                                       ! GET ANOTHER LINE
      NTOKES=0
      GO TO 210
  230 CONTINUE
      IF( TYPES(NPARAM) .EQ. 'A') THEN
          ctemp = token
          CALL upcase( token, nchars )
          IF( NAMES(NPARAM) .EQ. 'HIRES' .AND.
     &        (TOKEN(1:NCHARS).EQ.'YES' .OR. TOKEN(1:NCHARS).EQ.'1'))
     &        hires = 1
          IF(NAMES(NPARAM).EQ.'ADDWB'.AND.TOKEN(1:NCHARS).EQ.'YES')
     *        IADDWB = 1
          IF( names(nparam) .EQ. 'OPATH' ) THEN
              IF( icompt .EQ. 4 .OR. icompt .EQ. 7 )
     *            ctemp(nchars+1:nchars+1) = CHAR(0)                    ! Unix wants a null terminator
              IF( token(nchars-3:nchars) .EQ. 'SEGY' .OR.
     *            token(nchars-2:nchars) .EQ. 'MAT') THEN
                  nsegyfile(nmonum) = 1
                  IF ( token(nchars-2:nchars) .EQ. 'MAT' )
     &                 nsegyfile(nmonum) = 2
                  CALL getfil( 3, lunvtp, ctemp, istat )
              ELSE
                  nsegyfile(nmonum) = 0
                  CALL getfil( 2, lunvtp, ctemp, istat )
                  INQUIRE( FILE = ctemp, EXIST = iexist )
                  IF( iexist ) THEN
                      OPEN( UNIT=lunvtp, FILE=ctemp, STATUS='OLD')
                      CLOSE( UNIT = lunvtp, STATUS = 'DELETE' )
                  ENDIF
                  OPEN( UNIT=lunvtp, FILE=ctemp, ACCESS='SEQUENTIAL',
     &                  FORM = 'FORMATTED', STATUS = 'NEW' )
              ENDIF
          ENDIF
          GOTO 100
      ENDIF
      CALL UPCASE(TOKEN,NCHARS)
      CALL DCODE(TOKEN,NCHARS,AREAL,ISTAT)                              ! TRY AND DECODE IT
      IF(ISTAT.EQ.2) GO TO 420                                          !=2 MEANS IT IS A NUMERIC
      IERROR=IERROR+1                                                   ! DCODE PRINTED AN ERROR
      GO TO 100
  420 IF(TYPES(NPARAM).EQ.'L') GO TO 500
      IF(NPARAM.LT.MULTIV) GO TO 490                                    !  IS IT A MULTIVALUED PARAMETER
      NS=NS+1                                                           ! THE TOKEN WAS A MULTI-VALUED PARAMETER
      nvtps = ns
      IF( NAMES(NPARAM) .EQ. 'VTP' .OR. names(nparam) .EQ. 'IVTP' )
     &    BUF(NS+NPARS)=AREAL
      IF( names(nparam) .EQ. 'IVTP' ) itype = 5
      VTP=0.
      GO TO 100
  490 VALS(NPARAM)=AREAL                                                !  FLOATING POINT VALUES
      GO TO 100
  500 CONTINUE                                                          ! 32 BIT INTEGER VALUES
      LVALS(NPARAM)=AREAL
      GO TO 100
C****
C****   FINISHED A LIST, NOW DO THE ERROR AND VALIDITY CHECKS
C****
 1000 CONTINUE                                                          ! MAKE SURE ALL SHOT & RP NUMBERS INCREASE
      IF(LNO.EQ.32768) LNO=FNO                                          ! DEFAULT LNO TO FNO
      IF(FNO.GT.LLNO) GO TO 1020                                        ! IS FNO LARGER THAN THE LAST LNO
      PRINT 1010
 1010 FORMAT(' ***  ERROR  ***  SHOT AND RP NUMBERS MUST INCREASE.')
      IERROR=IERROR+1
 1020 IF(LNO.GE.FNO) GO TO 1030                                         ! DO THEY INCREASE IN THIS LIST
      PRINT 1010
      IERROR=IERROR+1
 1030 LLNO=LNO
      IF(VTP.GE.0.) GO TO 1070
      PRINT 1060
 1060 FORMAT(' ***  ERROR  ***  VTP NOT GIVEN.')
      IERROR=IERROR+1
 1070 CONTINUE
      IF(STRETC.GT..001) GO TO 1090                                     !  STRETCH 0F 0 KILLS MOST DATA!!
      PRINT 1080
 1080 FORMAT(' ***  ERROR  ***  STRETC MUST BE .GT. .001')
      IERROR=IERROR+1
 1090 CONTINUE
      IF(VTRKWB.GT.0.0 .OR. VTRKWB.EQ.-9999.0) GOTO 1120
      PRINT 1100
 1100 FORMAT(' ***  ERROR  ***  VTRKWB MUST BE A POSITIVE NUMBER')
      IERROR=IERROR+1
 1120 CONTINUE                                                          ! CHECK ON ITYPE
      IF( newx .NE. -123456 ) THEN
          IF( itype .EQ. 0 ) itype = 4
          IF( itype .NE. 4 ) THEN
              PRINT *,' ***  ERROR  ***  ITYPE must be 4 with NEWX.'
              ierror = ierror + 1
          ENDIF
      ENDIF
      IF( itype .EQ. 0 ) itype = 1
      IF( ITYPE .LE. 0 .OR. ITYPE .GT. 5 ) THEN
          PRINT *,'  ***  ERROR  *** TYPE must be between 1 and 5.'
          ierror = ierror + 1
      ENDIF
      IF( itype .EQ. 4 .AND. newx .EQ. -123456 ) THEN
          PRINT *,' ***  ERROR  ***  NEWX must be given with TYPE 4 NMO'
          ierror = ierror + 1
      ENDIF
      DO II=1,nvtps,2                                                   !  CHECK THE VTP FOR ERRORS
         I = II+NPARS
         IF( BUF(I) .LE. 0 ) THEN
             PRINT 1150,BUF(I)
 1150        FORMAT(' ***  ERROR  ***  ILLEGAL VTP VELOCITY OF ',F10.4)
             IERROR=IERROR+1
         ENDIF
         IF( vmul .NE. 1. .OR. vadd .NE. 0. )
     &           buf(i) = (buf(i) - vadd) * vmul + vadd
         IF( II .NE. 1 ) THEN
             IF( buf(i) .LE. buf(i-2) .AND. vintpl .NE. 2 ) THEN
                 PRINT 1160
 1160            FORMAT(' ***  WARNING  *** Spatial variation with ',
     &              'non-increasing velocities will be wrong.')
                 iwarn = iwarn+1
             ENDIF
         ENDIF
         J=I+1                                                      ! now do the time checks
         IF(BUF(J).GE.0.AND.BUF(J).LT.20.) GO TO 1180
            PRINT 1170,BUF(J)
 1170       FORMAT(' ***  ERROR  ***  ILLEGAL VTP TIME OF ',F10.4)
            IERROR=IERROR+1
 1180    CONTINUE
         IF( II .NE. 1 ) THEN
             IF( BUF(J) .LE. BUF(J-2) ) THEN
                 PRINT 1191,BUF(J)
 1191            FORMAT(' ***  ERROR  ***  VTP TIME OF ',F10.4,
     &                 ' DECREASED.')
                 IERROR=IERROR+1
             ENDIF
         ENDIF
      ENDDO
      IF( nlists(nmonum) .GT. 0 .AND. itype .EQ. 5 .AND.
     &    nvtps .NE. lastnvtps ) THEN
          PRINT *,' ***  ERROR  ***  Different number of IVTP pairs.'
          ierror = ierror + 1
      ENDIF
      lastnvtps = nvtps
      IF( stretc .EQ. 1. .AND. itype .NE. 1 ) stretc = 100.
      IF( vintpl .EQ. 99999 ) THEN
          IF( itype .NE. 5 ) THEN
              vintpl = 1
          ELSE
              vintpl = 4
          ENDIF
      ENDIF
      IF( vintpl .LT. 1 .OR. vintpl .GT. 4 ) THEN
          PRINT *,' ***  ERROR  ***  VINTPL must be between 1 and 4.'
          ierror = ierror + 1
      ENDIF
C****
C****      WRITE THE PARAMETER LIST TO DISC
C****
      IF(nvtps.LE.MAXVTP) GO TO 1360
      ITEMP=MAXVTP
      PRINT 1350,ITEMP
 1350 FORMAT(' ***  ERROR  ***  NMO CAN HANDLE ONLY ',I3,' VTPS.')
      IERROR=IERROR+1
 1360 CONTINUE
      LBUF(1)=FNO
      LBUF(2)=LNO
      BUF(3)=STRETC
      LBUF(4)=ITYPE
      LBUF(5)=IADDWB
      LBUF(6)=LPRINT
      LBUF(7)=VINTPL
      BUF(8)=VTRKWB
      lbuf(11) = lunvtp
      lbuf(12) = newx
      IF( maxdt .NE. 0 ) buf(3) = maxdt
      buf(14) = dstretch
      buf(16) = xfactor
      buf(17) = hires
      LBUF(npars)=nvtps
      ITEMP=NPARS+1
      ITEMP1=NPARS+nvtps
      IF(IAND(LPRINT,1).EQ.1)  PRINT 2010,(LBUF(I),I=1,2),
     * BUF(3),(LBUF(J),J=4,7),BUF(8), LBUF(11),lbuf(12),
     & (BUF(J),J=ITEMP,ITEMP1)
 2010 FORMAT(' NMO PARAMS:',/,2(1X,I10),1X,F10.4,1X,I10,1X,I4,
     *    2(1X,I10),1x,F10.4,2(1X,I10),/,2(1X,F10.3))
      CALL WRDISC(NUNIT(nmonum),BUF,NWRDS)
      nlists(nmonum) = nlists(nmonum)+1
c****
c**** If we're to write a SEGY file for the velocities, do the SEGY headers
c****
      IF( lunvtp .NE. 0 .AND. nsegyfile(nmonum) .EQ. 1 .AND.
     &    nlists(nmonum) .EQ. 1 ) THEN
          CALL podisc( ihunit, 0, 0 )
          CALL rddiscb( ihunit, buf, 3200, istat )
          CALL wrdiscb( lunvtp, buf, 3200 )
          CALL rddiscb( ihunit, buf, 400, istat )
c****   syn doesn't set the sample interval
          ibuf(11) = numdat  !  number of samples
          ibuf(13) = 5   ! IEEE FP
          IF( icompt .EQ. 2 .OR. icompt .EQ. 4 )
     *        CALL SWAP16( ibuf, 200 )
          CALL wrdiscb( lunvtp, buf, 400 )
      ENDIF
c**** finish up.  buf has been clobbered!
      NS=0
      nvtps = 0
      LLNO=LNO
      LNO=32768                                                         ! DEFAULT THE DEFAULTS
 2020 CALL GETOKE(TOKEN,NCHARS)                                         ! GET THE NEXT TOKEN
      CALL UPCASE(TOKEN,NCHARS)
      NTOKES=NTOKES+1
      IF(NCHARS.GT.0) GO TO 2030                                        !WAS IT THE END OF A LINE?
      IF(NOW.EQ.1) PRINT 140
      CALL RDLINE                                                       ! GET ANOTHER LINE
      NTOKES=0
      GO TO 2020
 2030 IF(TOKEN(1:NCHARS).NE.'END'.OR.NCHARS.NE.3) GO TO 150
      RETURN                                                            !  FINISHED ALL OF THE PARAMETERS!!!
      END


C NMR: NMR_FITRELAX
C ----
C
C Fit a relaxation type curve to the supplied data
C
C Input:
C   - file for fitting
C Output:
C   - graphical output
C
C Notes:
C   The fitting assumes a relaxation curve of one of the following forms:
C   "opt_code"
C   ---------------------------------------------------------------------
C       0         A (1 - exp(-t/tr))
C       1         B + A (1 - exp(-t/tr))
C       2         A (1 - exp(-(t-t0)/tr))
C       3         B + A (1 - exp(-(t-t0)/tr))
C       4         A (1 - exp(-t/tr))/(1 - cos(theta)exp(-t/tr))
C       5         A (1 - exp(-t/tr))/(1 - cos(theta)exp(-t/tr))
C       6         B + A (1 - exp(-t/tr))/(1 - cos(theta)exp(-t/tr))
C       7         A (1 - 2 exp(-t/tr))
C   ---------------------------------------------------------------------
C   where the "A", "B" and "t0" are constants, tr is the relaxation time
C   and the final form is used for fitting progressive saturation
C   experiments.
C
C The following steps are taken depending on what data are supplied:
C  opt_code 0:
C   The user supplies estimates for A and tr which are then iterated
C   until a best fit is found.
C  opt_code 1:
C   As for 0, but the user supplies and initial estimate of B
C  opt_code 2:
C   As for 0, but the user supplies and initial estimate of t0
C  opt_code 3:
C   As for 0, but the user supplies and initial estimate of B & t0
C  opt_code 4:
C   The user explicitly requests fitting for progressive saturation data.
C   Initial estimates for A, tr and THETA must be supplied.
C  opt_code 5:
C   As for opt_code=4, but theta is not iterated.
C  opt_code 6:
C   As for opt_code=5, but another parameter, an offset B, is iterated.
C  opt_code 7:
C   Inversion recovery form for relaxation
C
C For all fits the NAG routine E04FDF is used for the least squares
C minimization.
C
C
       implicit   NONE
C
C Data file definitions
       integer    max_size
       parameter (max_size = 1024)
       integer    npts
C Estimates for relaxation curve
       real*4     A, B, tr, t0, theta
       integer    iset_A, iset_B, iset_tr, iset_t0, iset_theta
C options
       integer    opt_code
       integer    iprogsat, fixed_theta, invrec
C array for fitted data spectrum
       real*4     xfit(max_size), yfit(max_size), x_max
C data arrays passed in common
       real*4     x(max_size), y(max_size), xx, xx1, scale, step
       common    /fitdat/ x, y, scale, opt_code, theta
C
C Output unit
       integer    iout
       parameter (iout = 6)
C
C Local variables used in NAG fit
       integer    len_work
       parameter (len_work = 400 + 16*max_size)
       real*8     fsumsq, fit(4), work(len_work)
       integer    nvals, ndata, iwork(100), ifail
C loop counter
       integer    n
C file and directory name
       character*256  dir, file
C unit and spectrum identifiers
       integer        iunit, id
C status
       integer        status
C test variable
       logical        test

C standard include files
       include '/mrao/include/chrlib_functions.inc'
       include '../include/spec_global.inc'
       include '../include/spec_pars.inc'

C initialise
       call io_initio
       call cmd_extpars( 'SPECTRUM', dir, status )
       call cmd_getiline( 'nmr_fitrelax',
     *      dir(1:chr_lenb(dir))//anal_definitions, status)

C find input file name and allocate file
       call cmd_items( 'file', file, status)
       call spec_allocate( file(1:chr_lenb(file)),
     *                     'read', id, status)
C read data
       call spec_get_data( id, 1, x, npts, status)
       call spec_get_data( id, 2, y, npts, status)
       scale = y(npts)
       x_max = -1.0E+30
       do n = 1,npts
         x_max = max(x_max,x(n))
       enddo
C deallocate
       call spec_deallocate( id, status )

C read in the control data
       call cmd_itemr( 'a', 1, A, status )
       call cmd_itemr( 'b', 1, B, status )
       call cmd_itemr( 'tr', 1, tr, status )
       call cmd_itemr( 't0', 1, t0, status )
       call cmd_itemr( 'theta', 1, theta, status )
       theta = theta*3.14159265/180.0
       call cmd_itemset( 'a', test, status )
       iset_A = 0
       if (test) iset_A = 1
       call cmd_itemset( 'b', test, status )
       iset_B = 0
       if (test) iset_B = 1
       call cmd_itemset( 'tr', test, status )
       iset_tr = 0
       if (test) iset_tr = 1
       call cmd_itemset( 't0', test, status )
       iset_t0 = 0
       if (test) iset_t0 = 1
       call cmd_itemset( 'theta', test, status )
       iset_theta = 0
       if (test) iset_theta = 1
       call cmd_itemset( 'progsat', test, status )
       iprogsat = 0
       if (test) iprogsat = 1
       call cmd_itemset( 'fixed_theta', test, status )
       fixed_theta = 0
       if (test) fixed_theta = 1
       call cmd_itemset( 'invrec', test, status )
       invrec = 0
       if (test) invrec = 1

C read in the data
       if ( status.ne.0 ) goto 999

C ensure zero values for offsets
       if (iset_B.eq.0)  B  = 0.0
       if (iset_t0.eq.0) t0 = 0.0

C sort out options
       fit(1) = A/scale
       fit(2) = tr
       nvals = 2
       opt_code = 0
       if (iset_B.eq.1 .and. iset_t0.eq.0 .and. iprogsat.eq.0) then
         fit(3) = B/scale
         nvals = 3
         opt_code = 1
       elseif (iset_B.eq.0 .and. iset_t0.eq.1 .and. iprogsat.eq.0) then
         fit(3) = t0
         nvals = 3
         opt_code = 2
       elseif (iset_B.eq.1 .and. iset_t0.eq.1 .and. iprogsat.eq.0) then
         fit(3) = B/scale
         fit(4) = t0
         nvals = 4
         opt_code = 3
       elseif (iprogsat.eq.1) then
         if (fixed_theta.eq.0) then
           fit(3) = theta
           nvals = 3
           opt_code = 4
         else
           nvals = 2
           opt_code = 5
           if (iset_B.eq.1) then
             fit(3) = B/scale
             nvals = 3
             opt_code = 6
           end if
         end if
       end if
       if (invrec.eq.1) then
         nvals = 2
         opt_code = 7
       end if

C fit a relaxation curve to the data
       ndata = npts
       ifail = 1
       call e04fdf(ndata, nvals, fit, fsumsq,
     *             iwork, 100, work, len_work, ifail)
       if (ifail.ne.0) then
         print *,'***(FITRELAX) Ifail non-zero from NAG = ',ifail
         if (ifail.eq.1) goto 999
       end if
       A = fit(1)*scale
       tr = fit(2)
       if (opt_code.eq.1) then
         B = fit(3) * scale
       else if (opt_code.eq.2) then
         t0 = fit(3)
       else if (opt_code.eq.3) then
         B = fit(3) * scale
         t0= fit(4)
       else if (iprogsat.eq.1) then
         if (fixed_theta.eq.0) then
           theta = fit(3)
         else if (opt_code.eq.6) then
           B = fit(3) * scale
         end if
       end if
       theta = theta/(3.14159265/180.0)
       if (iprogsat.eq.0) then
         write( iout, 100 ) ndata, fsumsq, A, tr, B, t0
100      format(1X/
     *          1X,'.. Results of fitting B + A(1-exp(-(t-t0)/tr))'/
     *          1X,'.. Number data points = ',I12,
     *          1X,'   Sum of squares     = ',1PE12.3/
     *          1X,'..                 A  = ',1PE12.3,
     *          1X,'   Relaxation time tr = ',1PE12.3/
     *          1X,'..                 B  = ',1PE12.3,
     *          1X,'                   t0 = ',1PE12.3)
       else
         write( iout, 110 ) ndata, fsumsq, A, tr, theta, B
110      format(1X/
     *          1X,'.. Results of fitting      A(1-exp(-t/tr))'/
     *          1X,'..                     ------------------------'/
     *          1X,'..                     (1-cos(theta)exp(-t/tr))'/
     *          1X,'.. Number data points = ',I12,
     *          1X,'   Sum of squares     = ',1PE12.3/
     *          1X,'..                 A  = ',1PE12.3,
     *          1X,'   Relaxation time tr = ',1PE12.3/
     *          1X,'..              theta = ',1PE12.3,
     *          1X,'                   B  = ',1PE12.3)
       end if

C construct output spectrum as a fit to these data
       xx1 = 0.0
       step = (1.1*x_max-xx1)/float(10*ndata-1)
       theta = theta*3.14159265/180.0
       call cmd_items('fit',file,status)
       call io_opefil( iunit, file(1:chr_lenb(file)), 'WRITE', 0,
     *                 status )
       write(iunit,*)'%ncols 2 '
       write(iunit,*)'%ndata ',10*ndata
       if (iprogsat.eq.0) then
         do n=1,10*ndata
           xx = xx1 + float(n-1)*step
           xfit(n) = xx
           if (invrec.eq.1) then
             yfit(n) = A*(1.0 - 2.0*exp(-xx/tr))
           else
             yfit(n) = B + A*(1.0 - exp(-(xx-t0)/tr))
           end if
           write(iunit,*) xfit(n), yfit(n)
         end do
       else
         do n=1,10*ndata
           xx = xx1 + float(n-1)*step
           xfit(n) = xx
           yfit(n) = B + A*(1.0 - exp(-xx/tr)) /
     *                  (1.0 - cos(theta)*exp(-xx/tr))
           write(iunit,*) xfit(n), yfit(n)
         end do
       end if
       close (iunit)

999    continue

       end
C
C
       subroutine LSFUN1( ndata, nvals, fit, f )
C
C Routine required by NAG -- see definition in NAG manual for details
C
       integer    nvals, ndata
       real*8     fit(nvals), f(ndata)

C Data passed in common
       integer    max_size
       parameter (max_size = 1024)
       real*4     x(max_size), y(max_size), scale
       integer    opt_code
       real*4     theta
       common    /fitdat/ x, y, scale, opt_code, theta

       integer    n, nn

       nn = 0
       if (opt_code.eq.0) then
         do n=1,ndata
            if (abs( x(n)/fit(2) ).lt.100.0) then
              f(n) = y(n)/scale -
     *               (fit(1)*(1.0D+0-exp(-(x(n))/fit(2))))
            else
              f(n) = y(n) - fit(1)
            end if
         end do
       else if (opt_code.eq.1) then
         do n=1,ndata
            if (abs( x(n)/fit(2) ).lt.100.0) then
              f(n) = y(n)/scale - fit(3) -
     *               (fit(1)*(1.0D+0-exp(-(x(n))/fit(2))))
            else
              f(n) = y(n) - fit(1) - fit(3)
            end if
         end do
       else if (opt_code.eq.2) then
         do n=1,ndata
            if (abs( (x(n)-fit(3))/fit(2) ).lt.100.0) then
              f(n) = y(n)/scale -
     *               (fit(1)*(1.0D+0-exp(-(x(n)-fit(3))/fit(2))))
            else
              f(n) = y(n) - fit(1)
            end if
         end do
       else if (opt_code.eq.3) then
         do n=1,ndata
            if (abs( (x(n)-fit(4))/fit(2) ).lt.100.0) then
              f(n) = y(n)/scale - fit(3) -
     *               (fit(1)*(1.0D+0-exp(-(x(n)-fit(4))/fit(2))))
            else
              f(n) = y(n) - fit(1) - fit(3)
            end if
         end do
       else if (opt_code.eq.4) then
         do n=1,ndata
            if (abs( x(n)/fit(2) ).lt.100.0) then
              f(n) = y(n)/scale -
     *               (fit(1)*(1.0D+0-exp(-(x(n))/fit(2))))/
     *               (1.0D+0-cos(fit(3))*exp(-(x(n))/fit(2)))
            else
              f(n) = y(n) - fit(1)
            end if
         end do
       else if (opt_code.eq.5) then
         do n=1,ndata
            if (abs( x(n)/fit(2) ).lt.100.0) then
              f(n) = y(n)/scale -
     *               (fit(1)*(1.0D+0-exp(-(x(n))/fit(2))))/
     *               (1.0D+0-cos(theta)*exp(-(x(n))/fit(2)))
            else
              f(n) = y(n) - fit(1)
            end if
         end do
       else if (opt_code.eq.6) then
         do n=1,ndata
            if (abs( x(n)/fit(2) ).lt.100.0) then
              f(n) = y(n)/scale - fit(3) -
     *               (fit(1)*(1.0D+0-exp(-(x(n))/fit(2))))/
     *               (1.0D+0-cos(theta)*exp(-(x(n))/fit(2)))
            else
              f(n) = y(n) - fit(1) - fit(3)
            end if
         end do
       elseif (opt_code.eq.7) then
         do n=1,ndata
            if (abs( x(n)/fit(2) ).lt.100.0) then
              f(n) = y(n)/scale -
     *               (fit(1)*(1.0D+0-2.0*exp(-(x(n))/fit(2))))
            else
              f(n) = y(n) - fit(1)
            end if
         end do
       end if
       end


!==========================================================================
elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, &
                                   v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag)
! =========================================================================
!
!  Calculates five second-order derivatives of specific volume (v).
!  Note that this function uses the computationally-efficient
!  expression for specific volume (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  v_SA_SA  =  The second derivative of specific volume with respect to
!              Absolute Salinity at constant CT & p.    [ J/(kg (g/kg)^2) ]
!  v_SA_CT  =  The second derivative of specific volume with respect to
!              SA and CT at constant p.                  [ J/(kg K(g/kg)) ]
!  v_CT_CT  =  The second derivative of specific volume with respect to
!              CT at constant SA and p.                      [ J/(kg K^2) ]
!  v_SA_P  =  The second derivative of specific volume with respect to
!              SA and P at constant CT.                  [ J/(kg K(g/kg)) ]
!  v_CT_P  =  The second derivative of specific volume with respect to
!              CT and P at constant SA.                  [ J/(kg K(g/kg)) ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p
integer, intent(in), optional :: iflag
real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p

integer :: i
logical :: flags(5)
real (r8) :: v_ct_ct_part, v_ct_p_part, v_sa_ct_part, v_sa_p_part
real (r8) :: v_sa_sa_part, xs, xs2, ys, z

xs2 = gsw_sfac*sa + offset
xs = sqrt(xs2)
ys = ct*0.025_r8
z = p*1e-4_r8

if (present(iflag)) then
    do i = 1, 5
        flags(i) = btest(iflag,i)
    end do
else
    flags = .true.
end if

if (present(v_sa_sa) .and. flags(1)) then

   v_sa_sa_part = (-b000 + xs2*(b200 + xs*(2.0_r8*b300 + xs*(3.0_r8*b400 &
       + 4.0_r8*b500*xs))) + ys*(-b010 + xs2*(b210 + xs*(2.0_r8*b310 &
       + 3.0_r8*b410*xs)) + ys*(-b020 + xs2*(b220 + 2.0_r8*b320*xs) &
       + ys*(-b030 + b230*xs2 + ys*(-b040 - b050*ys)))) + z*(-b001 &
       + xs2*(b201 + xs*(2.0_r8*b301 + 3.0_r8*b401*xs)) + ys*(-b011 &
       + xs2*(b211 + 2.0_r8*b311*xs) + ys*(-b021 + b221*xs2 &
       + ys*(-b031 - b041*ys))) + z*(-b002 + xs2*(b202 + 2.0_r8*b302*xs) &
       + ys*(-b012 + b212*xs2 + ys*(-b022 - b032*ys)) + z*(-b003 &
       - b013*ys - b004*z))))/xs2

   v_sa_sa = 0.25_r8*gsw_sfac*gsw_sfac*v_sa_sa_part/xs

end if

if (present(v_sa_ct) .and. flags(2)) then

   v_sa_ct_part = (b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) &
       + ys*(2.0_r8*(b020 + xs*(b120 + xs*(b220 + b320*xs))) &
       + ys*(3.0_r8*(b030 + xs*(b130 + b230*xs)) + ys*(4.0_r8*(b040 + b140*xs) &
       + 5.0_r8*b050*ys))) + z*(b011 + xs*(b111 + xs*(b211 + b311*xs)) &
       + ys*(2.0_r8*(b021 + xs*(b121 + b221*xs)) + ys*(3.0_r8*(b031 + b131*xs) &
       + 4.0_r8*b041*ys)) + z*(b012 + xs*(b112 + b212*xs) + ys*(2.0_r8*(b022 &
       + b122*xs) + 3.0_r8*b032*ys) + b013*z)))/xs

   v_sa_ct = 0.025_r8*0.5_r8*gsw_sfac*v_sa_ct_part

end if

if (present(v_ct_ct) .and. flags(3)) then

   v_ct_ct_part = a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) &
       + ys*(2.0_r8*(a020 + xs*(a120 + xs*(a220 + a320*xs))) &
       + ys*(3.0_r8*(a030 + xs*(a130 + a230*xs)) + ys*(4.0_r8*(a040 &
       + a140*xs) + 5.0_r8*a050*ys))) + z*( a011 + xs*(a111 + xs*(a211 &
       + a311*xs)) + ys*(2.0_r8*(a021 + xs*(a121 + a221*xs)) &
       + ys*(3.0_r8*(a031 + a131*xs) + 4.0_r8*a041*ys)) + z*(a012 &
       + xs*(a112 + a212*xs) + ys*(2.0_r8*(a022 + a122*xs) &
       + 3.0_r8*a032*ys) + a013*z))

   v_ct_ct = 0.025_r8*0.025_r8*v_ct_ct_part

end if

if (present(v_sa_p) .and. flags(4)) then

   v_sa_p_part = b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) + ys*(b011 &
       + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 + xs*(b121 + b221*xs) &
       + ys*(b031 + b131*xs + b041*ys))) + z*(2.0_r8*(b002 + xs*(b102 &
       + xs*(b202 + b302*xs)) + ys*(b012 + xs*(b112 + b212*xs) + ys*(b022 &
       + b122*xs + b032*ys))) + z*(3.0_r8*(b003 + b103*xs + b013*ys) &
       + 4.0_r8*b004*z))

   v_sa_p = 1e-8_r8*0.5_r8*gsw_sfac*v_sa_p_part

end if

if (present(v_ct_p) .and. flags(5)) then

   v_ct_p_part = a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) + ys*(a011 &
        + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 + xs*(a121 + a221*xs) &
        + ys*(a031 + a131*xs + a041*ys))) + z*(2.0_r8*(a002 + xs*(a102 &
	+ xs*(a202 + a302*xs)) + ys*(a012 + xs*(a112 + a212*xs) + ys*(a022 &
	+ a122*xs + a032*ys))) + z*(3.0_r8*(a003 + a103*xs + a013*ys) &
	+ 4.0_r8*a004*z))

   v_ct_p = 1e-8_r8*0.025_r8*v_ct_p_part

end if

return
end subroutine

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


      subroutine diffuse
c
c***********************************************************************
c     artificial mass and energy diffusion
c.......................................................................
c     called by: contin, gasnrg{h,rh}
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
      include'titan.com'
      include'titan.eq3'
c
      if (sig .eq. 0.0D0) return
      xtht = xmu * thet
c
c=======================================================================
c     mass diffusion
c=======================================================================
c
      if (zet .eq. 0.0D0) then
c
            do 1 k = ngrs, ngre + 1
c
c           equation c42
c
             df     (k) =    2.0D0 * sig *  rmu(k) * ( d(k  ) - d(k-1) )
     .                                             / ( r(k+1) - r(k-1) )
c
c           equations c43 - c45
c
            ddfdlrp1(k) = - df(k) * thet * rn(k+1) / ( r(k+1) - r(k-1) )
            ddfdlr00(k) =   df(k) * xtht * rn(k  ) /   r(k  )
            ddfdlrm1(k) = + df(k) * thet * rn(k-1) / ( r(k+1) - r(k-1) )
c
c           equations c46 & c47
c
            ddfdld00(k) = + 2.0D0 * sig * ( rmu(k) / (r(k+1) - r(k-1)) )
     .                            * thet * dn(k  )
            ddfdldm1(k) = - 2.0D0 * sig * ( rmu(k) / (r(k+1) - r(k-1)) )
     .                            * thet * dn(k-1)
    1       continue
            return
      endif
c
c=======================================================================
c     energy diffusion
c=======================================================================
c
      if (zet .eq. 1.0D0) then
c
            do 2 k = ngrs, ngre + 1
c
c           equation c42
c
             df     (k) =           sig * rmu(k) * ( d (k  ) + d (k-1) )
     .                                           * ( eg(k  ) - eg(k-1) )
     .                                           / ( r (k+1) - r (k-1) )
c
c           equations c43 - c45
c
            ddfdlrp1(k) = - df(k) * thet * rn(k+1) / ( r(k+1) - r(k-1) )
            ddfdlr00(k) =   df(k) * xtht * rn(k  ) /   r(k  )
            ddfdlrm1(k) = + df(k) * thet * rn(k-1) / ( r(k+1) - r(k-1) )
c
c           equations c46 & c47
c
            ddfdle00    = +  thet * sig * rmu(k  ) / ( r(k+1) - r(k-1) )
     .                                  * egn(k  ) * ( d(k  ) + d(k-1) )
            ddfdlem1    = -  thet * sig * rmu(k  ) / ( r(k+1) - r(k-1) )
     .                                  * egn(k-1) * ( d(k  ) + d(k-1) )
c
c           equations c48 & c49
c
            ddfdld00(k) =   df(k) * thet * dn(k  ) / ( d(k  ) + d(k-1) )
     .                  + ddfdle00 * dlegdldn(k  )
            ddfdldm1(k) =   df(k) * thet * dn(k-1) / ( d(k  ) + d(k-1) )
     .                  + ddfdlem1 * dlegdldn(k-1)
c
c           equations fe58 & fe59
c
            ddfdlt00(k) = ddfdle00 * dlegdltn(k  )
            ddfdltm1(k) = ddfdlem1 * dlegdltn(k-1)
    2       continue
            return
      endif
c
c-----------------------------------------------------------------------
c
      stop 'diffuse'
      end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine prop_elec_ms
  use global_variables_ms
  implicit none
  integer :: im,ikz,ikr
  real(8) :: a,b,c,Act_t,Etz

  do im = Mx_s,Mx_e

    c = Az(im)
    b = (Az_new(im)-Az_old(im))/(2d0*dt)
    a = (Az_new(im) - 2d0*Az(im) + Az_old(im))/(dt**2)

!=== deps_int, deps ====
    Act_t = Az(im)
    do ikz = -NKz,NKz
      kz(ikz) = kz0(ikz) + Act_t
      do ikr = 1,NKr
        deps(ikr,ikz,im) = eps_g + 0.5d0/mass_r*(kr(ikr)**2+kz(ikz)**2)
      end do
    end do
    deps_int(:,:,im) = deps_int(:,:,im) + 0.5d0*(dt*0.5d0)*deps(:,:,im)

    Act_t = 0.5d0*a*(dt/2d0)**2 + b*dt/2d0 + c
    do ikz = -NKz,NKz
      kz(ikz) = kz0(ikz) + Act_t
      do ikr = 1,NKr
        deps(ikr,ikz,im) = eps_g + 0.5d0/mass_r*(kr(ikr)**2+kz(ikz)**2)
      end do
    end do
    deps_int(:,:,im) = deps_int(:,:,im) + 0.5d0*(dt*0.5d0)*deps(:,:,im)
!=== deps_int, deps ====

    Etz = -(Az_new(im)-Az(im))/dt
    call dt_evolve_ms(Etz,im)

!=== deps_int, deps ====
    Act_t = 0.5d0*a*(dt/2d0)**2 + b*dt/2d0 + c
    do ikz = -NKz,NKz
      kz(ikz) = kz0(ikz) + Act_t
      do ikr = 1,NKr
        deps(ikr,ikz,im) = eps_g + 0.5d0/mass_r*(kr(ikr)**2+kz(ikz)**2)
      end do
    end do
    deps_int(:,:,im) = deps_int(:,:,im) + 0.5d0*(dt*0.5d0)*deps(:,:,im)

    Act_t = 0.5d0*a*dt**2 + b*dt + c
    do ikz = -NKz,NKz
      kz(ikz) = kz0(ikz) + Act_t
      do ikr = 1,NKr
        deps(ikr,ikz,im) = eps_g + 0.5d0/mass_r*(kr(ikr)**2+kz(ikz)**2)
      end do
    end do
    deps_int(:,:,im) = deps_int(:,:,im) + 0.5d0*(dt*0.5d0)*deps(:,:,im)
!=== deps_int, deps ====
  end do

  return
end subroutine prop_elec_ms


      program potent
c
c**********************************************************************
c
c     dl_poly utility program
c
c     construct potential arrays for silica and related systems
c     based on Vessal's model for constant volume systems:
c     Phil. Mag. B 60 (1989) 753-775
c
c     copyright - daresbury laboratory 1994
c     author    - w. smith july 1994
c
c**********************************************************************
c
      implicit real*8(a-h,o-z)
      parameter (mxgrid=5000,ntable=10)
      dimension uuu(mxgrid,2),ggg(mxgrid,2),elrc(2),vlrc(2)
      character*8 silicon,oxygen
      write(*,'(a)')'dl_poly utility to create potential tables'
      write(*,'(a)')'for Vessal constant volume silica potential'
      write(*,*)
      write(*,'(a)')'Please specify potential cutoff range (rcut)'
      read(*,*) rcut
      write(*,'(a)')'Please specify number of grid points (mxgrid)'
      read(*,*) maxgrd
      if(maxgrd.gt.mxgrid)then
         write(*,'(a)')'Error - too many grid points requested'
         stop
      endif
      rpd=rcut/dble(maxgrd-4)
      silicon='Si4+    '
      oxygen='O2-     '

c
c     silicon-oxygen potential
      j=1
      do i=1,maxgrd
        rrr=dble(i)*rpd
        rsq=rrr**2
        if(rrr.lt.1.5d0)then
          uuu(i,j)=990.617d0*exp(-rrr/0.3297d0)
          ggg(i,j)=rsq*uuu(i,j)/(rrr*0.3297d0)
        else if(rrr.lt.2.5d0)then
          uuu(i,j)=728.7931332d0+rrr*(
     x         -1623.5166500d0+rrr*(1496.7899792d0+
     x         rrr*(-704.0045699d0+rrr*(167.0744823d0
     x         -rrr*15.8848138d0))))
          ggg(i,j)=-rsq*(-1623.5166500d0+rrr*(1496.7899792d0*2.d0+
     x         rrr*(-704.0045699d0*3.d0+rrr*(167.0744823d0*4.d0-
     x         rrr*15.8848138d0*5.d0))))/rrr
        else if(rrr.lt.3.5d0)then
          uuu(i,j)=0.6187898d0+rrr*(-0.6702747d0+rrr*(
     x         0.2214821d0-rrr*0.0233139d0))
          ggg(i,j)=-rsq*(-0.67027470+rrr*(0.2214821d0*2.d0-
     x         rrr*0.0233139d0*3.d0))/rrr
        else if(i.le.maxgrd)then
          uuu(i,j)=-25.d0/rrr**6
          ggg(i,j)=-6.d0*25.d0*rsq/rrr**8
        endif
      enddo
      elrc(1)=uuu(maxgrd-4,1)*rcut**3/3.d0
      vlrc(1)=-2.d0*uuu(maxgrd-4,1)*rcut**3
c
c     oxygen-oxygen potential
      j=2
      do i=1,maxgrd
        rrr=dble(i)*rpd
        rsq=rrr**2
        if(rrr.lt.2.9d0)then
          uuu(i,j)=4511887.2d0*exp(-rrr/0.149d0)
          ggg(i,j)=rsq*uuu(i,j)/(rrr*0.149d0)
        else if(rrr.lt.3.6d0)then
          uuu(i,j)=298.0818367d0+rrr*(-453.1251863d0+
     x         rrr*(275.1200462d0+
     x         rrr*(-83.3698778d0+rrr*(12.6055881d0-
     x         rrr*0.7606781d0))))
          ggg(i,j)=-rsq*(-453.1251863d0+rrr*(275.1200462d0*2.d0+
     x         rrr*(-83.3698778d0*3.d0+rrr*(12.6055881d0*4.d0-
     x         rrr*0.7606781d0*5.d0))))/rrr
        else if(rrr.lt.4.2d0)then
          uuu(i,j)=1.5952103d0+rrr*(-1.2208242d0+rrr*
     x         (0.3052061d0-
     x         rrr*0.0251198d0))
          ggg(i,j)=-rsq*(-1.2208242d0+rrr*(0.3052061d0*2.d0-
     x         rrr*0.0251198d0*3.d0))/rrr
        else if(i.le.maxgrd)then
          uuu(i,j)=-52.12d0/rrr**6
          ggg(i,j)=-6.d0*52.12d0*rsq/rrr**8
        endif
      enddo
      elrc(2)=uuu(maxgrd-4,2)*rcut**3/3.d0
      vlrc(2)=-2.d0*uuu(maxgrd-4,2)*rcut**3
c
c     conversions to required units
      do  j=1,2
        elrc(j)=elrc(j)*1.60217733e-19/1.6605402e-23
        vlrc(j)=vlrc(j)*1.60217733e-19/1.6605402e-23
        do  i=1,maxgrd
          uuu(i,j)=uuu(i,j)*1.60217733e-19/1.6605402e-23
          ggg(i,j)=ggg(i,j)*1.60217733e-19/1.6605402e-23
        enddo
      enddo
c
c     write out potentials
      open(ntable,file='TABLE')
      write(ntable,'(a)')'Silica Potential - DL_POLY units'
      write(ntable,'(1p,2e15.8,i10)')rpd,rcut,maxgrd
      do k=1,2
        if(k.eq.1)write(ntable,'(2a8,1p,2e15.8)')
     x    silicon,oxygen,elrc(1),vlrc(1)
        if(k.eq.2)write(ntable,'(2a8,1p,2e15.8)')
     x    oxygen,oxygen,elrc(2),vlrc(2)
        write(ntable,'(1p,4e15.8)')(uuu(i,k),i=1,maxgrd)
        write(ntable,'(1p,4e15.8)')(ggg(i,k),i=1,maxgrd)
      enddo
      close (ntable)
      stop
      end


c
c -------------------------------------------------------------
c
      subroutine errest (nvar,naux,lcheck,mptr,nx)
c
      use amr_module
      use adjoint_module, only : adjoint_flagging, errf1a
      implicit double precision (a-h,o-z)
c
c   ### changed to stack based storage 2/23/13
c   ### and broken into smaller routines to minimize
c   ### stack space

      integer, intent(in) :: nvar,naux,lcheck,nx

      double precision valbgc(nvar,nx/2+2*nghost)
      double precision auxbgc(naux,nx/2+2*nghost)

c :::::::::::::::::::::::::: ERREST :::::::::::::::::::::::::::::::::::
c for this grid at level lcheck:
c  estimate the error by taking a large (2h,2k) step based on the
c  values in the old storage loc., then take one regular (and for
c  now wasted) step based on the new info.   compare using an
c  error relation for a pth order  accurate integration formula.
c  flag error plane as either bad (needs refinement), or good.
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c
       mitot  = nx + 2*nghost
       locnew = node(store1,mptr)
       locold = node(store2,mptr)
       locaux = node(storeaux,mptr)
       mi2tot = nx/2  + 2*nghost
c
c     prepare double the stencil size worth of boundary values,
c            then coarsen them for the giant step integration.
       midub = nx+4*nghost
c
       call prepbigstep(nvar,naux,lcheck,mptr,nx,midub,
     .                    valbgc,auxbgc,mi2tot)

c
c  the one giant step based on old values is done. now take
c  one regular step based on new values.
c  boundary values already in locbig, (see subr. flagger)
c
      locbig = node(tempptr,mptr)
      locaux = node(storeaux,mptr)
      call prepregstep(nvar,naux,lcheck,mptr,nx,mitot,
     .                 alloc(locbig),alloc(locaux))
c
c     ## locamrflags allocated in flagger. may previously have been used
c     ## by flagregions1 or flag2refine so make sure not to overwrite
      locamrflags = node(storeflags, mptr)
      mbuff = max(nghost,ibuff+1)
      mibuff = nx + 2*mbuff
      if(adjoint_flagging) then
          call errf1a(alloc(locbig),nvar,valbgc,mptr,mi2tot,
     1           mitot,alloc(locamrflags),mibuff,
     1           alloc(locaux),naux)
      else
          call errf1(alloc(locbig),nvar,valbgc,mptr,mi2tot,
     1           mitot,alloc(locamrflags),mibuff)
      endif

c
      return
      end


      subroutine invert(order,a,i,nsiz)
c******************************************************************************
c     This routine inverts an *order,order* matrix *a*. answer is *i*
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      integer order, orde
      real*8 a(nsiz,nsiz), i(nsiz,nsiz)

      do n=1,order
         do m=1,order
            i(m,n) = 0.0
         enddo
      enddo
      do j=1,order
         i(j,j) = 1.0
      enddo
      orde=order-1
      do k=1,orde
         kk = k+1
         do j=kk,order
            i(j,k) = 0.0
            i(k,j) = 0.0
         enddo
      enddo

c  here begins the inversion
      do n=1,order
         if (n .eq. order) go to 244
         g = a(n,n)
         n1 = n+1
         ng = n
         do m=n1,order
            f = a(m,n)
            if (f .gt. g) then
               g = f
               ng = m
            endif
         enddo
         if (ng .eq. n) go to 244
         do k=1,order
            d = i(n,k)
            e = i(ng,k)
            f = a(n,k)
            g = a(ng,k)
            i(ng,k) = d
            i(n,k) = e
            a(ng,k) = f
            a(n,k) = g
         enddo
244      g = a(n,n)
         if (g .eq. 0.0) then
            write (nf1out,1001)
            return
         endif
         do k=1,order
            a(n,k) = a(n,k)/g
            i(n,k) = i(n,k)/g
         enddo
         if (n .eq. order) go to 27
         do k=n1,order
            f = -a(k,n)
            do j=1,order
               a(k,j) = a(k,j) + f*a(n,j)
               i(k,j) = i(k,j)+f*i(n,j)
            enddo
         enddo
      enddo

27    do jk=1,orde
         n = order - jk + 1
         do j=jk,orde
            m = order - j
            f = -a(m,n)
            do k=1,order
            a(m,k) = a(m,k) + f*a(n,k)
            i(m,k) = i(m,k) + f*i(n,k)
            enddo
         enddo
      enddo
      return

c*****format statements
1001  format('WARNING: AN UN-INVERTABLE ARRAY HAS BEEN ENCOUNTERED!')

      end


      subroutine fastf(xreal, ximag, isize, itype)
c
c       Algorithm AS 83.1 Appl. Statist. (1975) vol.24, no.1
c
c       Radix 4 complex discrete fast Fourier transform with
c       unscrambling of the transformed arrays.
c
      real    xreal(isize), ximag(isize)
c
c       Check for valid transform size.
c
      ii = 4
      do 2 k = 2, 20
        if (ii .eq. isize) go to 4
        if (ii .gt. isize) go to 3
        ii = ii * 2
    2 continue
c
c       If this point is reached a size error has occurred.
c
    3 return
c
c       Call FASTG to perform the transform.
c
    4 call fastg(xreal, ximag, isize, itype)
c
c       Call SCRAM to unscramble the results.
c
      call scram(xreal, ximag, isize, k)
c
      return
      end
c
c
c
      subroutine fastg(xreal, ximag, n, itype)
c
c       Algorithm AS 83.2 Appl. Statist. (1975) vol.24, no.1
c
c       Radix 4 complex discrete fast Fourier transform without
c       unscrambling, suitable for convolutions or other applications
c       which do not require unscrambling.   Called by subroutine
c       FASTF which also does the unscrambling.
c
      real    xreal(n), ximag(n)
      data    zero, half, one, one5, two, four
     +          /0.0,  0.5, 1.0,  1.5, 2.0,  4.0/
      pi = four * atan(one)
      ifaca = n / 4
      if (itype .eq. 0) return
      if (itype .gt. 0) go to 5
c
c       ITYPE < 0 indicates inverse transform required.
c       Calculate conjugate.
c
      do 4 k = 1, n
    4 ximag(k) = -ximag(k)
c
c       Following code is executed for IFACA = N/4, N/16, N/64, ...
c       until IFACA <= 1.
c
    5 ifcab = ifaca * 4
      z = pi / ifcab
      bcos = -two * sin(z)**2
      bsin = sin(two * z)
      cw1 = one
      sw1 = zero
      do 10 litla = 1, ifaca
        do 8 i0 = litla, n, ifcab
          i1 = i0 + ifaca
          i2 = i1 + ifaca
          i3 = i2 + ifaca
          xs0 = xreal(i0) + xreal(i2)
          xs1 = xreal(i0) - xreal(i2)
          ys0 = ximag(i0) + ximag(i2)
          ys1 = ximag(i0) - ximag(i2)
          xs2 = xreal(i1) + xreal(i3)
          xs3 = xreal(i1) - xreal(i3)
          ys2 = ximag(i1) + ximag(i3)
          ys3 = ximag(i1) - ximag(i3)
          xreal(i0) = xs0 + xs2
          ximag(i0) = ys0 + ys2
          x1 = xs1 + ys3
          y1 = ys1 - xs3
          x2 = xs0 - xs2
          y2 = ys0 - ys2
          x3 = xs1 - ys3
          y3 = ys1 + xs3
          if (litla .eq. 1) then
            xreal(i2) = x1
            ximag(i2) = y1
            xreal(i1) = x2
            ximag(i1) = y2
            xreal(i3) = x3
            ximag(i3) = y3
          else
            xreal(i2) = x1 * cw1 + y1 * sw1
            ximag(i2) = y1 * cw1 - x1 * sw1
            xreal(i1) = x2 * cw2 + y2 * sw2
            ximag(i1) = y2 * cw2 - x2 * sw2
            xreal(i3) = x3 * cw3 + y3 * sw3
            ximag(i3) = y3 * cw3 - x3 * sw3
          end if
    8   continue
c
c       Calculate a new set of twiddle factors.
c
        if (litla .lt. ifaca) then
          z = cw1 * bcos - sw1 * bsin + cw1
          sw1 = bcos * sw1 + bsin * cw1 + sw1
          tempr = one5 - half * (z * z + sw1 * sw1)
          cw1 = z * tempr
          sw1 = sw1 * tempr
          cw2 = cw1 * cw1 - sw1 * sw1
          sw2 = two * cw1 * sw1
          cw3 = cw1 * cw2 - sw1 * sw2
          sw3 = cw1 * sw2 + cw2 * sw1
        end if
   10 continue
      if (ifaca .le. 1) go to 14
c
c       Set up the transform split for the next stage.
c
      ifaca = ifaca / 4
      if (ifaca .gt. 0) go to 5
c
c       Radix 2 calculation, if needed.
c
      if (ifaca .lt. 0) return
      do 13 k = 1, n, 2
        tempr = xreal(k) + xreal(k+1)
        xreal(k+1) = xreal(k) - xreal(k+1)
        xreal(k) = tempr
        tempr = ximag(k) + ximag(k+1)
        ximag(k+1) = ximag(k) - ximag(k+1)
        ximag(k) = tempr
   13 continue
   14 if (itype .lt. 0) then
c
c       Inverse transform; conjugate the result.
c
        do 16 k = 1, n
   16   ximag(k) = -ximag(k)
        return
      end if
c
c       Forward transform
c
      z = one / n
      do 18 k = 1, n
        xreal(k) = xreal(k) * z
        ximag(k) = ximag(k) * z
   18 continue
c
      return
      end
c
c
c
      subroutine scram(xreal, ximag, n, ipow)
c
c       Algorithm AS 83.3 Appl. Statist. (1975) vol.24, no.1
c
c       Subroutine for unscrambling FFT data.
c
      real    xreal(n), ximag(n)
      integer l(19)
      equivalence (l1,l(1)), (l2,l(2)), (l3,l(3)), (l4,l(4)),
     +          (l5,l(5)), (l6,l(6)), (l7,l(7)), (l8,l(8)), (l9,l(9)),
     +          (l10,l(10)), (l11,l(11)), (l12,l(12)), (l13,l(13)),
     +          (l14,l(14)), (l15,l(15)), (l16,l(16)), (l17,l(17)),
     +          (l18,l(18)), (l19,l(19))
c
      ii = 1
      itop = 2 ** (ipow - 1)
      i = 20 - ipow
      do 5 k = 1, i
    5 l(k) = ii
      l0 = ii
      i = i + 1
      do 6 k = i, 19
        ii = ii * 2
        l(k) = ii
    6 continue
c
      ii = 0
      do 9 j1 = 1, l1, l0
        do 9 j2 = j1, l2, l3
          do 9 j3 = j2, l3, l2
            do 9 j4 = j3, l4, l3
              do 9 j5 = j4, l5, l4
                do 9 j6 = j5, l6, l5
                  do 9 j7 = j6, l7, l6
                    do 9 j8 = j7, l8, l7
                      do 9 j9 = j8, l9, l8
                        do 9 j10 = j9, l10, l9
                          do 9 j11 = j10, l11, l10
                            do 9 j12 = j11, l12, l11
                              do 9 j13 = j12, l13, l12
                                do 9 j14 = j13, l14, l13
                                  do 9 j15 = j14, l15, l14
                                    do 9 j16 = j15, l16, l15
                                      do 9 j17 = j16, l17, l16
                                        do 9 j18 = j17, l18, l17
                                          do 9 j19 = j18, l19, l18
                                            j20 = j19
                                            do 9 i = 1, 2
                                              ii = ii + 1
                                              if (ii .lt. j20) then
c
c       J20 is the bit-reverse of II pairwise interchange.
c
                                                tempr = xreal(ii)
                                                xreal(ii) = xreal(j20)
                                                xreal(j20) = tempr
                                                tempr = ximag(ii)
                                                ximag(ii) = ximag(j20)
                                                ximag(j20) = tempr
                                              end if
                                              j20 = j20 + itop
    9 continue
c
      return
      end


!---------------------------------------------------------------------
!---------------------------------------------------------------------
! snh: Bifurcations of global reinjection orbits near a saddle-node
!      Hopf bifurcation: cycle-to-point connections
!
! Parameters:
!   PAR(1) : nu1
!   PAR(2) : nu2
!   PAR(3) : d
!   PAR(4) : codimension of connection (0 or 1)
!
!   PAR(5) : delta: distance from cycle to start connection
!   PAR(6) : eps: distance from end connection to point
!   PAR(7) : mu: log of the Floquet multiplier
!   PAR(8) : h: norm of eigenfunction for cycle at 0
!   PAR(9) : T^-: time for connection from cycle (U(7:9)) to section
!   PAR(10) : T^+: time for connection from section (U(10:12)) to point
!   PAR(11) : T: period of the cycle
!   PAR(21) : sigma-: U1(9)-pi (phi-distance W^u(P) from section phi=pi)
!                     ( distance to W^u(b) for codim 0 connection)
!   PAR(22) : sigma+: U0(12)-pi (phi-distance W^s(E) from section phi=pi)
!   PAR(23) : eta: gap size for Lin vector
!   PAR(24) : Z_x: Lin vector (x-coordinate)
!   PAR(25) : Z_y: Lin vector (y-coordinate)
!   PAR(26) : Z_z: Lin vector (z-coordinate)
!---------------------------------------------------------------------
!---------------------------------------------------------------------

  SUBROUTINE RHS(U,PAR,F,JAC,A)

    IMPLICIT NONE
    DOUBLE PRECISION, INTENT(IN) :: U(3), PAR(*)
    LOGICAL, INTENT(IN) :: JAC
    DOUBLE PRECISION, INTENT(OUT) :: F(3), A(3,3)

    DOUBLE PRECISION x, y, phi
    DOUBLE PRECISION nu1, nu2, alpha, beta, omega, c, d, fp, s
    DOUBLE PRECISION sphi, x2y2, cphinu, cphinu2

    nu1 = PAR(1)
    nu2 = PAR(2)
    d = PAR(3)
    fp = 4*atan(1.0d0)*d
    alpha = -1
    s = -1
    c = 0
    omega = 1
    beta = 0

    x = U(1)
    y = U(2)
    phi = U(3)

    sphi = sin(phi)
    x2y2 = x*x + y*y
    cphinu = 2*cos(phi)+nu2
    cphinu2 = cphinu*cphinu

    F(1) = nu1*x - omega*y - (alpha*x - beta*y)*sphi - x2y2*x + d*cphinu2
    F(2) = nu1*y + omega*x - (alpha*y + beta*x)*sphi - x2y2*y + fp*cphinu2
    F(3) = nu2 + s*x2y2 + 2.0*cos(phi) + c*x2y2*x2y2

    IF(JAC)THEN
       A(1,1) = nu1 - alpha*sphi - 3*x**2 - y**2
       A(1,2) = -omega + beta*sphi - 2*x*y
       A(1,3) = -(alpha*x - beta*y)*cos(phi) - d*4*(2*cos(phi)+nu2)*sphi

       A(2,1) = omega - beta*sphi - 2*x*y
       A(2,2) = nu1 - alpha*sphi - 3*y**2 - x*x
       A(2,3) = -(alpha*y + beta*x)*cos(phi) - fp*4*(2*cos(phi) + nu2)*sphi

       A(3,1) = 2*s*x + 4*c*x2y2*x
       A(3,2) = 2*s*y + 4*c*x2y2*y
       A(3,3) = -2*sphi
    ENDIF

  END SUBROUTINE RHS

  SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
! ---------- ---

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
    DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
    DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
    DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM),DFDP(NDIM,*)

    DOUBLE PRECISION T,mu
    DOUBLE PRECISION A(3,3)

    CALL RHS(U,PAR,F,NDIM>3,A)
    IF(NDIM==3)RETURN

    F(4:6) = MATMUL(A,U(4:6))

    T = PAR(11)
    F(1:6) = F(1:6) * T

    ! log of Floquet multiplier in PAR(7)
    mu = PAR(7)
    F(4:6) = F(4:6) - mu*U(4:6)

    IF (NDIM==6) RETURN

    CALL RHS(U(7:9),PAR,F(7:9),.FALSE.,A)

    T = PAR(9)
    F(7:9) = F(7:9) * T

    IF (NDIM==9) RETURN

    CALL RHS(U(10:12),PAR,F(10:12),.FALSE.,A)

    T = PAR(10)
    F(10:12) = F(10:12) * T

  END SUBROUTINE FUNC

  SUBROUTINE STPNT(NDIM,U,PAR,T)
  !--------- -----

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM
    DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
    DOUBLE PRECISION, INTENT(IN) :: T

    INTEGER, PARAMETER :: codim = 1
    DOUBLE PRECISION, PARAMETER :: nu1 = 0, nu2 = -1.46d0, d = 0.01d0
    DOUBLE PRECISION, PARAMETER :: delta = -1d-5, eps = 1d-6
    DOUBLE PRECISION fp(3), ev(3), pi
    DOUBLE PRECISION, SAVE :: s(6)

    IF(NDIM==9)THEN
       IF(T==0)THEN
          s(1:6) = U(1:6)
       ENDIF
       U(7:9) = s(1:3) + PAR(5)*s(4:6)
       RETURN
    ELSEIF(NDIM==12)THEN
       fp = (/0d0, 0d0, acos(-nu2/2)/)
       ev = (/0d0, 0d0, 1d0/)
       U(10:12) = fp(1:3) + PAR(6)*ev(1:3)
       RETURN
    ENDIF

    PAR(1:3) = (/nu1,nu2,d/)
    PAR(4) = codim
    PAR(5) = delta
    PAR(6) = eps
    PAR(21:22) = 0.0

    ! homotopy: equilibrium b and its phase-shifted version, to find
    ! the "heteroclinic" orbit in negative time.
    pi = 4 * ATAN(1D0)
    PAR(11) = -0.1
    PAR(12) = 0
    PAR(13) = 0
    PAR(14) = acos(-PAR(2)/2)
    PAR(15) = 0
    PAR(16) = 0
    PAR(17) = acos(-PAR(2)/2)+2*pi
    PAR(18) = 0.01d0 ! epsilon_0 distance

    ! equilibrium a
    U(1:3) = (/ 0.0d0, 0.0d0, 2*pi-acos(-nu2/2) /)

  END SUBROUTINE STPNT

  SUBROUTINE PVLS(NDIM,U,PAR)
  !--------- ----

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM
    DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
    DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)

    DOUBLE PRECISION, EXTERNAL :: GETP
    DOUBLE PRECISION d(3), normlv
    INTEGER i, NBC, codim
    DOUBLE PRECISION pi
    LOGICAL, SAVE :: FIRST = .TRUE.

    IF (FIRST) THEN
       FIRST = .FALSE.
       ! initialization for BCND
       pi = 4d0 * ATAN(1d0)
       IF (NDIM==9) THEN
          codim = NINT(PAR(4))
          IF (codim == 0) THEN
             IF (PAR(21)==0) THEN
                ! distance to W^u(b) where b is the phase-shifted equilibrium
                PAR(21) = GETP("BV1",9,U) - PAR(17)
             ENDIF
          ELSE
             PAR(21) = GETP("BV0",9,U) - pi
          ENDIF
       ELSEIF (NDIM==12) THEN
          NBC = AINT(GETP("NBC",0,U))
          IF (NBC==15) THEN
             PAR(22) = GETP("BV0",12,U) - pi
          ELSE
             ! check if Lin vector initialized:
             IF (DOT_PRODUCT(PAR(24:26),PAR(24:26)) > 0) RETURN
             DO i=1,3
                d(i) = GETP("BV1",6+i,U) - GETP("BV0",9+i,U)
             ENDDO
             normlv = sqrt(DOT_PRODUCT(d,d))
             ! gap size in PAR(23)
             PAR(23) = normlv
             ! Lin vector in PAR(24)-PAR(26)
             PAR(24:26) = d(1:3)/normlv
          ENDIF
       ENDIF
    ENDIF
  END SUBROUTINE PVLS

  SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
  !--------- ----

    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
    DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
    DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
    DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

    DOUBLE PRECISION nu2, delta, eps, fp(3), ev(3), eta
    DOUBLE PRECISION pi
    INTEGER codim

    ! Periodicity boundary conditions on state variables
    FB(1:3) = U0(1:3) - U1(1:3)

    ! Floquet boundary condition
    FB(4:6) = U1(4:6) - U0(4:6)

    ! normalization
    FB(7) = PAR(8) - DOT_PRODUCT(U0(4:6),U0(4:6))
    IF (NBC==7) RETURN

    delta = PAR(5)
    FB(8:10) = U0(7:9) - (U0(1:3) + delta*U0(4:6))
    pi = 4d0 * ATAN(1d0)
    codim = NINT(PAR(4))
    IF(codim == 0)THEN
       ! projection boundary condition for codimension-zero connection
       nu2 = PAR(2)
       FB(11) = COS(U1(9) - PAR(21)) +nu2/2
       RETURN
    ENDIF
    FB(11) = U1(9) - pi - PAR(21)

    IF (NBC==11) RETURN

    nu2 = PAR(2)
    eps = PAR(6)
    IF (abs(nu2) > 2) THEN
       ! truncate nu2 to [-2,2] to avoid floating point exceptions with acos
       nu2 = sign(2d0, nu2)
    ENDIF

    fp = (/0d0, 0d0, acos(-nu2/2)/)
    ev = (/0d0, 0d0, 1d0/)

    FB(12:14) = U1(10:12) - (fp(1:3) + eps*ev(1:3))

    IF (NBC==15) THEN
       FB(15) = U0(12) - pi - PAR(22)
       RETURN
    ENDIF

    eta = PAR(23)
    FB(15:17) = U1(7:9) - U0(10:12) - eta*PAR(24:26)

  END SUBROUTINE BCND

  SUBROUTINE ICND(NDIM,PAR,ICP,NINTS,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
  !--------- ----
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: NDIM, ICP(*), NINTS, IJAC
    DOUBLE PRECISION, INTENT(IN) :: PAR(*)
    DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
    DOUBLE PRECISION, INTENT(OUT) :: FI(NINTS)
    DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINTS,*)

    INTEGER codim

    ! Integral phase condition
    FI(1) = DOT_PRODUCT(U(1:3),UPOLD(1:3))
    IF (NINTS==1) RETURN

    codim = NINT(PAR(4))
    IF (codim == 0) THEN
       ! phase condition for codimension-zero connection
       FI(2) = DOT_PRODUCT(UPOLD(7:9),U(7:9)-UOLD(7:9))
       RETURN
    ENDIF
    FI(2) = DOT_PRODUCT(UPOLD(10:12),U(10:12)-UOLD(10:12))
  END SUBROUTINE ICND

  SUBROUTINE FOPT(NDIM,U,ICP,PAR,IJAC,FS,DFDU,DFDP)
  END SUBROUTINE FOPT


PROGRAM GravitationalCollapse1D

  USE KindModule, ONLY: &
    DP, Pi
  USE UnitsModule, ONLY: &
    Kilometer, &
    MeV, &
    Millisecond
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE InitializationModule, ONLY: &
    InitializeGravitationalCollapse
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SSP_RK

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
            = 'GravitationalCollapse1D', &
           nX_Option &
             = [ 256, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 10, 0, 0 ], &
           xL_Option &
             = [ 0.0d0 * Kilometer, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 8.0d3 * Kilometer, Pi,     4.0_DP ], &
           zoomX_Option &
             = [ 1.020059256924853_DP, 1.0_DP, 1.0_DP ], &
           nE_Option &
             = 1, &
           eL_Option &
             = 0.0d0 * MeV, &
           eR_Option &
             = 1.0d2 * MeV, &
           ZoomE_Option &
             = 1.0_DP, &
           nNodes_Option &
             = 2, &
           CoordinateSystem_Option &
             = 'SPHERICAL', &
           ActivateUnits_Option &
             = .TRUE., &
           EquationOfState_Option &
             = 'TABLE', &
           EquationOfStateTableName_Option &
             = 'EquationOfStateTable.h5', &
           FluidSolver_Option &
             = 'Euler_DG', &
           FluidRiemannSolver_Option &
             = 'HLLC', &
           EvolveFluid_Option &
             = .TRUE., &
           RadiationSolver_Option &
             = 'M1_DG', &
           RadiationRiemannSolver_Option &
             = 'HLL', &
           EvolveRadiation_Option &
             = .FALSE., &
           ApplySlopeLimiter_Option &
             = .TRUE., &
           BetaTVB_Option &
             = 0.0d0, &
           BetaTVD_Option &
             = 1.0d0, &
           ApplyPositivityLimiter_Option &
             = .FALSE., &
           EvolveGravity_Option &
             = .TRUE., &
           GravitySolver_Option &
             = 'Newtonian_Poseidon', &
           nStages_SSP_RK_Option &
             = 2 )

  CALL InitializeGravitationalCollapse &
         ( ProgenitorFile = 'WH07_15M_Sun.h5' )

  CALL EvolveFields &
         ( t_begin  = 0.0d+0 * Millisecond, &
           t_end    = 4.0d+2 * Millisecond, &
           dt_write = 5.0d-1 * Millisecond, &
           UpdateFields = SSP_RK )

  CALL FinalizeProgram

END PROGRAM GravitationalCollapse1D


program mf_evolve

  use real_type_mod
  use output_mod
  use variables_mod
  use parameters_mod
  use evolve_mod
  use conversion_mod
  use initial_mod
  use analysis_mod
  use system_mod

  implicit none

!!$  Variables

  real(kind=wp), dimension(:), allocatable :: x
  real(kind=wp), dimension(:, :, :), allocatable :: n_up, mu_down, &
       n_down, mu_up, mu_down_p
  real(kind=wp), dimension(:, :), allocatable :: n_sqd

  integer :: i, istat, nt
  character(len=200) :: out_dir, parameter_file
  real(kind=wp) :: t

!!$  Read the command line and find out the input file

  if (iargc() .ne. 1) then
    write(*,*) 'Useage: mf_evolve <parameter file>'
    stop
  end if
  call getarg(1, parameter_file)

!!$  Set the parameters

  call set_parameters(parameter_file)

!!$  Open output files, backup parameter file and code

  out_dir = make_out_dir(out_dir_base)
  call execute_command(trim('cp '//trim(parameter_file)//' '//trim(out_dir)), istat)
  if (istat .ne. 0) then
    write(*,*) 'Copying the parameter file failed, ', istat
    stop
  end if
  call execute_command(trim('tar zcf '//trim(out_dir)//'/code.tgz Makefile *.f90'), &
       istat)
  if (istat .ne. 0) then
    write(*,*) 'Backing up code failed, ', istat
    stop
  end if
  call analysis_create_all(out_dir)
  if (do_fft) then
    call fft_setup(np)
  end if

!!$  Set up arrays

  allocate(n_up   (NF, NV, 1-gz:np+gz), &
           n_down (NF, NV, 1-gz:np+gz), &
           mu_up  (NF, NV, 1-gz:np+gz), &
           mu_down(NF, NV, 1-gz:np+gz), &
           mu_down_p(NF, NV, 1-gz:np+gz), &
           n_sqd  (NFF   , 1-gz:np+gz), &
           STAT=istat)

  allocate(x(1-gz:np+gz), &
           STAT=istat)

!!$  Set up initial data

  call initial(x, n_up)
  call all_from_n_up(n_up, n_down, mu_up, mu_down, n_sqd)
  mu_down_p = mu_down

  t = 0.0_wp

!!$  Output initial data

  call analysis_output_all(x, n_up, n_down, mu_up, mu_down, mu_down_p, n_sqd, &
       t, dt, dx)
  if (do_fft) then
    call analysis_fft(n_sqd, n_up, t)
  end if

!!$  Evolve

  nt = 0

  do while (t < t_end)

    mu_down_p = mu_down

    call evolve(n_up, n_down, mu_up, mu_down, n_sqd)
    nt = nt + 1
    t = t + dt

    if ( mod(nt, out_every) == 0 ) then
      write(*, *) 'Step ', nt, ' Time ', t
      call analysis_output_all(x, n_up, n_down, mu_up, mu_down, mu_down_p, &
           n_sqd, t, dt, dx)
    end if
!!$    Do the FFT at every step if requested
    if (do_fft) then
      if ( mod(nt, fft_out_every) == 0 ) then
        call analysis_fft(n_sqd, n_up, t)
      end if
    end if

  end do

!!$  End of program - close all files and deallocate

  call analysis_close_all()
  if (do_fft) then
    call fft_shutdown()
  end if

  deallocate(n_up, n_down, mu_up, mu_down, mu_down_p, n_sqd)

end program mf_evolve


\ based on a post on geeksforgeeks
\ https://www.geeksforgeeks.org/bresenhams-circle-drawing-algorithm/

S" dessin.f" INCLUDED    \ here is the OpenGL routines
S" rand.f" INCLUDED

0 value xtemp \  xtemp=0
0 value ytemp \  ytemp=0
0 value radius \  radius=0

\ variables for plotting circle
0 value PC_X
0 value PC_Y
0 value Xchange
0 value Ychange
0 value RadiusError
0 value CX
0 value CY
0 value R
0 value pc_d

\  INIT-MY-OPENGL          \ INITILIZE  OPENGL  VIEWPORT, MUST BE CLEANED, BUT WORKS

: BLUE    200 200 100 Color  ;

0e0  fvalue xn  0e0 fvalue yn

: SET-DOT    (  xn xy  --)
               s>f  fto yn   s>f  fto  xn    \ temporary buffer
          xn    80e0   F/    fto    X   \    x  f.
          yn    80e0   F/    fto    Y    \  y  f.    cr
         Point	        ;

 : P3  ( X Y --)   SET-DOT ;

 : P5  ( X Y --)   SET-DOT ;
 : P6  ( X Y --)   SET-DOT ;

: MS PAUSE ;

\ CODE FOR MISSING 0>
: 0>  0 > ;

\ ------------------------------------------
\ code for missing >=
\ ------------------------------------------
: >= ( n1 n2 -- flag )
  2dup >   \ copy both numbers, test for >
  rot rot  \ bring original 2 numbers to tos
  =        \ test for =
  or       \ or both flags for either or
;

\ missing <=
: <=  2dup < rot rot = or ;
 : F> F< 0= ;
 : F>S  ( --n) F>D  D>S  ;    \   float to integer)

: F2DUP         ( fs: r1 r2 -- r1 r2 r1 r2 )       \ W32F          Floating extra
\ *G Duplicate the top 2 FP stack entries.
                fover fover ;

0e FVALUE win.xleft
0e FVALUE win.xright
0e FVALUE win.ybot
0e FVALUE win.ytop
0e FVALUE win.xdif
0e FVALUE win.ydif

variable SXoffs
variable SXdiff
variable SYoffs
variable SYdiff

1.0e FVALUE PenX
1.0e FVALUE PenY

: SCALE         \ F: <x> <y> --- <>  <> --- <x> <y>
                win.ybot  F-  win.ydif F/  SYdiff @ S>F F*  F>S SYoffs @ +
                win.xleft F-  win.xdif F/  SXdiff @ S>F F*  F>S SXoffs @ +
                SWAP ;

\ -- Won't plot a point that doesn't fall within the window.
: PLOT-POINT  ;  \    PenX win.xleft win.xright       \ <color> --- <>
 \               F2DUP F> IF FSWAP THEN
  \                FWITHIN 0= IF DROP EXIT THEN
  \              PenY win.ybot  win.ytop
  \              F2DUP F> IF FSWAP THEN
  \                FWITHIN 0= IF DROP EXIT THEN
  \              PenX PenY SCALE ROT SET-DOT ;

\  : xypos        ( x y -- )
\                 to prev-y  to prev-x ;

: DrawCircle

CX PC_X +   CY PC_Y +  SET-DOT
CX PC_X -   CY PC_Y +  SET-DOT
CX PC_X -   CY PC_Y -  SET-DOT
CX PC_X +   CY PC_Y -  SET-DOT
CX PC_Y +   CY PC_X +  SET-DOT
CX PC_Y -   CY PC_X +  SET-DOT
CX PC_Y -   CY PC_X -  SET-DOT
CX PC_Y +   CY PC_X -  SET-DOT

;

: Bresenham

0 TO PC_X
R TO PC_Y
3 2 R * - to pc_d \ pc_d = 3-2*R
DrawCircle

BEGIN
   PC_Y PC_X >= \ WHILE PC_Y >= PC_X
WHILE
     \ For each pixel we will draw 8 pixels
     PC_X 1+ TO PC_X   \ PC_X = PC_X+1
     \ check for decision parameter and correspondingly update d, PC_X and PC_Y
     pc_d 0>   \ if pc_d>0
     if
       PC_Y 1- TO PC_Y \ PC_Y = PC_Y -1
       pc_d 4  PC_X PC_Y - * + 10 + to pc_d  \ pc_d = pc_d + 4*(PC_X - PC_Y) + 10
     else
       pc_d 4 PC_X * 6 + + to pc_d   \ pc_d = pc_d + 4*PC_X + 6
     then

     DrawCircle

REPEAT ;

: circle  Dessin 2  PointSize   \ CIR1 CIR2 ;

BLUE
\                  0.0E fto  X         0e0     fto  Y       Point
\              0 0 p3

   20 0 DO
         200 random 200 random 200 random color
         800 RANDOM  TO CX 800 RANDOM TO CY 400 RANDOM to R
         Bresenham view 400 PAUSE
        loop
   20000 pause
glclose
;

\ Create concentric circles situated at center (200,10) with R=100, decreasing radius by 10
: Concentric_Circles Dessin 2  PointSize

green
10 0 do
    400 TO R
   35 0 DO
         \ 200 random 200 random 200 random color
         20 to CX 15 TO CY R 10 - to R
         Bresenham view cls
         40 PAUSE
        loop loop
   20000 pause
   glclose

;

Concentric_Circles