! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! The Reaction Rates File
!
! Generated by KPP-2.1 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : cbm4_Rates.f90
! Time                 : Mon Feb 27 11:08:22 2017
! Working directory    : /data/ksetigui/setigui/WRFV3_171015/chem/KPP/mechanisms/cbm4
! Equation file        : cbm4.kpp
! Output root filename : cbm4
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE cbm4_Rates

  USE cbm4_Parameters
  USE cbm4_Global
  IMPLICIT NONE

CONTAINS

! Begin Rate Law Functions from KPP_HOME/util/UserRateLaws

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  User-defined Rate Law functions
!  Note: the default argument type for rate laws, as read from the equations file, is single precision
!        but all the internal calculations are performed in double precision
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!~~~>  Arrhenius
   REAL(kind=dp) FUNCTION ARR( A0,B0,C0 )
      REAL A0,B0,C0
      ARR =  DBLE(A0) * EXP(-DBLE(B0)/TEMP) * (TEMP/300.0_dp)**DBLE(C0)
   END FUNCTION ARR

!~~~> Simplified Arrhenius, with two arguments
!~~~> Note: The argument B0 has a changed sign when compared to ARR
   REAL(kind=dp) FUNCTION ARR2( A0,B0 )
      REAL A0,B0
      ARR2 =  DBLE(A0) * EXP( DBLE(B0)/TEMP )
   END FUNCTION ARR2

   REAL(kind=dp) FUNCTION EP2(A0,C0,A2,C2,A3,C3)
      REAL A0,C0,A2,C2,A3,C3
      REAL(dp) K0,K2,K3
      K0 = DBLE(A0) * EXP(-DBLE(C0)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      K3 = DBLE(A3) * EXP(-DBLE(C3)/TEMP)
      K3 = K3*CFACTOR*1.0E6_dp
      EP2 = K0 + K3/(1.0_dp+K3/K2 )
   END FUNCTION EP2

   REAL(kind=dp) FUNCTION EP3(A1,C1,A2,C2)
      REAL A1, C1, A2, C2
      REAL(dp) K1, K2
      K1 = DBLE(A1) * EXP(-DBLE(C1)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      EP3 = K1 + K2*(1.0E6_dp*CFACTOR)
   END FUNCTION EP3

   REAL(kind=dp) FUNCTION FALL ( A0,B0,C0,A1,B1,C1,CF)
      REAL A0,B0,C0,A1,B1,C1,CF
      REAL(dp) K0, K1
      K0 = DBLE(A0) * EXP(-DBLE(B0)/TEMP)* (TEMP/300.0_dp)**DBLE(C0)
      K1 = DBLE(A1) * EXP(-DBLE(B1)/TEMP)* (TEMP/300.0_dp)**DBLE(C1)
      K0 = K0*CFACTOR*1.0E6_dp
      K1 = K0/K1
      FALL = (K0/(1.0_dp+K1))*   &
           DBLE(CF)**(1.0_dp/(1.0_dp+(LOG10(K1))**2))
   END FUNCTION FALL

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

  ELEMENTAL REAL(dp) FUNCTION k_3rd(temp,cair,k0_300K,n,kinf_300K,m,fc)

    INTRINSIC LOG10

    REAL(dp), INTENT(IN) :: temp      ! temperature [K]
    REAL(dp), INTENT(IN) :: cair      ! air concentration [molecules/cm3]
    REAL,     INTENT(IN) :: k0_300K   ! low pressure limit at 300 K
    REAL,     INTENT(IN) :: n         ! exponent for low pressure limit
    REAL,     INTENT(IN) :: kinf_300K ! high pressure limit at 300 K
    REAL,     INTENT(IN) :: m         ! exponent for high pressure limit
    REAL,     INTENT(IN) :: fc        ! broadening factor (usually fc=0.6)
    REAL                 :: zt_help, k0_T, kinf_T, k_ratio

    zt_help = 300._dp/temp
    k0_T    = k0_300K   * zt_help**(n) * cair ! k_0   at current T
    kinf_T  = kinf_300K * zt_help**(m)        ! k_inf at current T
    k_ratio = k0_T/kinf_T
    k_3rd   = k0_T/(1._dp+k_ratio)*fc**(1._dp/(1._dp+LOG10(k_ratio)**2))

  END FUNCTION k_3rd

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

  ELEMENTAL REAL(dp) FUNCTION k_arr (k_298,tdep,temp)
    ! Arrhenius function

    REAL,     INTENT(IN) :: k_298 ! k at T = 298.15K
    REAL,     INTENT(IN) :: tdep  ! temperature dependence
    REAL(dp), INTENT(IN) :: temp  ! temperature

    INTRINSIC EXP

    k_arr = k_298 * EXP(tdep*(1._dp/temp-3.3540E-3_dp)) ! 1/298.15=3.3540e-3

  END FUNCTION k_arr

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  End of User-defined Rate Law functions
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! End Rate Law Functions from KPP_HOME/util/UserRateLaws

! Begin INLINED Rate Law Functions

! End INLINED Rate Law Functions

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_SUN - update SUN light using TIME
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  SUBROUTINE Update_SUN()
      !USE cbm4_Parameters
      !USE cbm4_Global

    IMPLICIT NONE

    REAL(kind=dp) SunRise, SunSet
    REAL(kind=dp) Thour, Tlocal, Ttmp

    SunRise = 4.5_dp
    SunSet  = 19.5_dp
    Thour = TIME/3600.0_dp
    Tlocal = Thour - (INT(Thour)/24)*24

    IF ((Tlocal>=SunRise).AND.(Tlocal<=SunSet)) THEN
       Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise)
       IF (Ttmp.GT.0) THEN
          Ttmp =  Ttmp*Ttmp
       ELSE
          Ttmp = -Ttmp*Ttmp
       END IF
       SUN = ( 1.0_dp + COS(PI*Ttmp) )/2.0_dp
    ELSE
       SUN = 0.0_dp
    END IF

 END SUBROUTINE Update_SUN

! End of Update_SUN function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_RCONST - function to update rate constants
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Update_RCONST ( )

! Begin INLINED RCONST

! End INLINED RCONST

  RCONST(1) = (j(pj_no2))
  RCONST(2) = (j(pj_o33p))
  RCONST(3) = (j(pj_o31d))
  RCONST(4) = (j(pj_no3o)+j(pj_no3o2))
  RCONST(5) = (j(pj_hno2))
  RCONST(6) = (j(pj_h2o2))
  RCONST(7) = (j(pj_ch2or))
  RCONST(8) = (j(pj_ch2om))
  RCONST(9) = (4.6D-4*j(pj_no2))
  RCONST(10) = (9.04_dp*j(pj_ch2or))
  RCONST(11) = (9.64_dp*j(pj_ch2or))
  RCONST(12) = (ARR2(1.4D+3,1175.0_dp,TEMP))
  RCONST(13) = (ARR2(1.8D-12,-1370.0_dp,TEMP))
  RCONST(14) = (9.3D-12)
  RCONST(15) = (ARR2(1.6D-13,687.0_dp,TEMP))
  RCONST(16) = (ARR2(2.2D-13,602.0_dp,TEMP))
  RCONST(17) = (ARR2(1.2D-13,-2450.0_dp,TEMP))
  RCONST(18) = (ARR2(1.9D+8,390.0_dp,TEMP))
  RCONST(19) = (2.2D-10)
  RCONST(20) = (ARR2(1.6D-12,-940.0_dp,TEMP))
  RCONST(21) = (ARR2(1.4D-14,-580.0_dp,TEMP))
  RCONST(22) = (ARR2(1.3D-11,250.0_dp,TEMP))
  RCONST(23) = (ARR2(2.5D-14,-1230.0_dp,TEMP))
  RCONST(24) = (ARR2(5.3D-13,256.0_dp,TEMP))
  RCONST(25) = (1.3D-21)
  RCONST(26) = (ARR2(3.5D+14,-10897.0_dp,TEMP))
  RCONST(27) = (ARR2(1.8D-20,530.0_dp,TEMP))
  RCONST(28) = (4.4D-40)
  RCONST(29) = (ARR2(4.5D-13,806.0_dp,TEMP))
  RCONST(30) = (6.6D-12)
  RCONST(31) = (1.0D-20)
  RCONST(32) = (ARR2(1.0D-12,713.0_dp,TEMP))
  RCONST(33) = (ARR2(5.1D-15,1000.0_dp,TEMP))
  RCONST(34) = (ARR2(3.7D-12,240.0_dp,TEMP))
  RCONST(35) = (ARR2(1.2D-13,749.0_dp,TEMP))
  RCONST(36) = (ARR2(4.8D+13,-10121.0_dp,TEMP))
  RCONST(37) = (ARR2(1.3D-12,380.0_dp,TEMP))
  RCONST(38) = (ARR2(5.9D-14,1150.0_dp,TEMP))
  RCONST(39) = (ARR2(2.2D-38,5800.0_dp,TEMP))
  RCONST(40) = (ARR2(3.1D-12,-187.0_dp,TEMP))
  RCONST(41) = (2.2D-13)
  RCONST(42) = (1.0D-11)
  RCONST(43) = (ARR2(3.0D-11,-1550.0_dp,TEMP))
  RCONST(44) = (6.3D-16)
  RCONST(45) = (ARR2(1.2D-11,-986.0_dp,TEMP))
  RCONST(46) = (ARR2(7.0D-12,250.0_dp,TEMP))
  RCONST(47) = (2.5D-15)
  RCONST(48) = (ARR2(5.4D-12,250.0_dp,TEMP))
  RCONST(49) = (ARR2(8.0D-20,5500.0_dp,TEMP))
  RCONST(50) = (ARR2(9.4D+16,-14000.0_dp,TEMP))
  RCONST(51) = (2.0D-12)
  RCONST(52) = (6.5D-12)
  RCONST(53) = (ARR2(1.1D+2,-1710.0_dp,TEMP))
  RCONST(54) = (8.1D-13)
  RCONST(55) = (ARR2(1.0D+15,-8000.0_dp,TEMP))
  RCONST(56) = (1.6D+03)
  RCONST(57) = (1.5D-11)
  RCONST(58) = (ARR2(1.2D-11,-324.0_dp,TEMP))
  RCONST(59) = (ARR2(5.2D-12,504.0_dp,TEMP))
  RCONST(60) = (ARR2(1.4D-14,-2105.0_dp,TEMP))
  RCONST(61) = (7.7D-15)
  RCONST(62) = (ARR2(1.0D-11,-792.0_dp,TEMP))
  RCONST(63) = (ARR2(2.0D-12,411.0_dp,TEMP))
  RCONST(64) = (ARR2(1.3D-14,-2633.0_dp,TEMP))
  RCONST(65) = (ARR2(2.1D-12,322.0_dp,TEMP))
  RCONST(66) = (8.1D-12)
! RCONST(67) = constant rate coefficient
  RCONST(68) = (4.1D-11)
  RCONST(69) = (2.2D-11)
  RCONST(70) = (1.4D-11)
  RCONST(71) = (ARR2(1.7D-11,116.0_dp,TEMP))
  RCONST(72) = (3.0D-11)
  RCONST(73) = (ARR2(5.4D-17,-500.0_dp,TEMP))
  RCONST(74) = (1.70D-11)
  RCONST(75) = (1.80D-11)
  RCONST(76) = (9.6D-11)
  RCONST(77) = (1.2D-17)
  RCONST(78) = (3.2D-13)
  RCONST(79) = (8.1D-12)
  RCONST(80) = (ARR2(1.7D-14,1300.0_dp,TEMP))
  RCONST(81) = (6.8D-13)

END SUBROUTINE Update_RCONST

! End of Update_RCONST function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_PHOTO - function to update photolytical rate constants
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Update_PHOTO ( )

   USE cbm4_Global

  RCONST(1) = (j(pj_no2))
  RCONST(2) = (j(pj_o33p))
  RCONST(3) = (j(pj_o31d))
  RCONST(4) = (j(pj_no3o)+j(pj_no3o2))
  RCONST(5) = (j(pj_hno2))
  RCONST(6) = (j(pj_h2o2))
  RCONST(7) = (j(pj_ch2or))
  RCONST(8) = (j(pj_ch2om))
  RCONST(9) = (4.6D-4*j(pj_no2))
  RCONST(10) = (9.04_dp*j(pj_ch2or))
  RCONST(11) = (9.64_dp*j(pj_ch2or))

END SUBROUTINE Update_PHOTO

! End of Update_PHOTO function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

END MODULE cbm4_Rates


module setup_init_mod

use constants_mod

real(dp), save :: nodes(N_NODES),ws(N_NODES)

contains

subroutine hook_init_810

    use share_mod, only: mesh

    use mesh_utils_mod, only: mesh_iterate_quads
    use mesh_utils_mod, only: mesh_refine

    use interpol_mod, only: LegendreGaussNodesAndWeights

    integer :: level

    call LegendreGaussNodesAndWeights(N_NODES-1,nodes,ws)
    nodes = 0.5_dp*nodes
    ws = 0.5_dp*ws

    do level = mesh%minlevel,mesh%maxlevel-1
        call mesh_refine(mesh,setup_init_probe_refine)
    end do
    call mesh_iterate_quads(mesh,fill)

end subroutine

subroutine fill(quad)

    use setup_config_mod
    use equations_const_mod

    use mesh_types_mod, only: quad_t
    use quad_utils_mod, only: quad_get_coords

    use setup_manufacsol_mod

    use share_mod, only: rt => runtime

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

    real(dp) :: dens(N_NODES,N_NODES,N_NODES)
    real(dp) :: velx(N_NODES,N_NODES,N_NODES)
    real(dp) :: vely(N_NODES,N_NODES,N_NODES)
    real(dp) :: velz(N_NODES,N_NODES,N_NODES)
    real(dp) :: momx(N_NODES,N_NODES,N_NODES)
    real(dp) :: momy(N_NODES,N_NODES,N_NODES)
    real(dp) :: momz(N_NODES,N_NODES,N_NODES)
    real(dp) :: pres(N_NODES,N_NODES,N_NODES)
    real(dp) :: ener(N_NODES,N_NODES,N_NODES)

    real(dp) :: coords(N_NODES,N_NODES,N_NODES,N_DIMS)
    real(dp) :: radius(N_NODES,N_NODES,N_NODES)

    real(dp) :: u(N_NODES,N_NODES,N_NODES,N_VARS)
    real(dp) :: r(N_NODES,N_NODES,N_NODES,N_VARS)

    real(dp) :: xs(N_NODES)
    real(dp) :: ys(N_NODES)
    real(dp) :: zs(N_NODES)

    real(dp) :: time

    integer :: i,j,k, ii,jj,kk

    coords = quad_get_coords(quad)

    u = 0.0_dp
    r = 0.0_dp

    time = rt%simtime
    !time = 0.0_dp
    ! time = 0.345_dp

    do k = 1,N_NODES; do j = 1,N_NODES; do i = 1,N_NODES;
        xs = coords(i,j,k,1) + quad%delta(1)/REAL(N_NODES,dp)*nodes
        ys = coords(i,j,k,2) + quad%delta(2)/REAL(N_NODES,dp)*nodes
        zs = coords(i,j,k,3) + quad%delta(3)/REAL(N_NODES,dp)*nodes

        do kk = 1,N_NODES; do jj = 1,N_NODES; do ii = 1,N_NODES;
            u(i,j,k,:) = u(i,j,k,:) + ws(ii)*ws(jj)*ws(kk)*init_manufacsol(time,xs(ii),ys(jj),zs(kk))
            r(i,j,k,:) = r(i,j,k,:) + ws(ii)*ws(jj)*ws(kk)*calc_manufacsol(time,xs(ii),ys(jj),zs(kk))
        end do; end do; end do
    end do; end do; end do

    quad%pld%hydro%state(:,:,:,DENS_VAR) = u(:,:,:,DENS_VAR)
    quad%pld%hydro%state(:,:,:,MOMX_VAR) = u(:,:,:,MOMX_VAR)
    quad%pld%hydro%state(:,:,:,MOMY_VAR) = u(:,:,:,MOMY_VAR)
    quad%pld%hydro%state(:,:,:,MOMZ_VAR) = u(:,:,:,MOMZ_VAR)
    quad%pld%hydro%state(:,:,:,ENER_VAR) = u(:,:,:,ENER_VAR)

    quad%aux%manufacsol%u0 = quad%pld%hydro%state
    quad%aux%manufacsol%st = r

end subroutine

function setup_init_probe_refine(quad) result(ok)

    use setup_config_mod
    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CORNERS
    use quad_utils_mod, only: quad_get_center
    use quad_utils_mod, only: quad_get_vertices

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

    real(dp) :: verts(N_DIMS,MESH_CORNERS)
    real(dp) :: center(N_DIMS)

    verts = quad_get_vertices(quad)

    center = quad_get_center(quad)

    ok = .false.

    ! return
    !if (rand() < 0.2) then
    if (any(abs(SQRT(SUM((verts)**2,dim=1))) < 0.5 * 0.5*diameter)) then
    ! if (center(1) < 0) then
    !if (all(center < 0)) then
        ok = .true.
    end if

end function

function setup_init_probe_coarsen(quads) result(ok)

    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CHILDREN
    use setup_config_mod, only: setup_amr_threshold_coarsen

    type(quad_t), intent(in)    :: quads(MESH_CHILDREN)
    logical                     :: ok

    real(dp)                    :: sensor(MESH_CHILDREN)

    integer :: i

    ok = .false.

end function

end module


      subroutine cudaclaw5_fort_update_q(meqn, mx, my, mbc, maux,
     &                                   dtdx, dtdy,qold,fp,fm,
     &                                   gp, gm, mcapa)
      implicit none

      integer meqn, mx, my, maux, mbc, mcapa
      double precision dtdx, dtdy

      double precision qold(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision fm(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision fp(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision gm(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision gp(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)

      integer m, i, j

      do m = 1,meqn
         do i = 1,mx
            do j = 1,my
               if (mcapa .eq. 0) then
c                 # no capa array.  Standard flux differencing:
                  qold(m,i,j) = qold(m,i,j)
     &                  - dtdx * (fm(m,i+1,j) - fp(m,i,j))
     &                  - dtdy * (gm(m,i,j+1) - gp(m,i,j))
               else
c                 # with capa array.
                  qold(m,i,j) = qold(m,i,j)
     &                  -(dtdx*(fm(m,i+1,j) - fp(m,i,j))
     &                  + dtdy*(gm(m,i,j+1) - gp(m,i,j)))/aux(mcapa,i,j)
               endif
            enddo
         enddo
      enddo

      end


      PROGRAM MAIN

C     RESULT REPORTING
C     CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(F18.15)"
      CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(E12.6)"

C     ----------------------------------------------
C     Variables and data for GPT
C     ----------------------------------------------
      DOUBLE PRECISION PRES, TEMP, UNDU

      CALL GPT(55055D0, 0.6708665767D0, -1.393397187D0, 812.546D0,
     .  PRES, TEMP, UNDU)

C     REPORT RESULTS
      PRINT *, '----------------------------------------'
      PRINT *, '> GPT Results:'
      PRINT *, '----------------------------------------'
      WRITE(*, FMT1) DABS(PRES-918.0710638757363995D0)
      WRITE(*, FMT1) DABS(TEMP-19.31914181012882992D0)
      WRITE(*, FMT1) DABS(UNDU+42.19185643717770517D0)

C     ALL DONE
      END


c***********************************************************************
c	                    COORD_VH2B_TP.F
c***********************************************************************
*     PURPOSE: Converts test part from Heliocentric to Barycentric coords.
*              Velocity only
*     ARGUMENTS:  Input is
*                              ntp ==> number of test part (<= NTPMAX)
*                                              (integer)
*		     vxht,vyht,vzht ==> heliocentric particle velocities
*                                             (real array)
*		     vxhs,vyhs,vzhs ==> bary vel of the Sun
*                                          (real scalar)
*                 Returned are
*                    vxbt,vybt,vzbt ==> bary. particle velocities
*                                            (real array)
*
*     Authors:  Hal Levison
*     ALGORITHM: Obvious
*     WRITTEN:  11/14/96
*     REVISIONS:

	subroutine coord_vh2b_tp(ntp,vxht,vyht,vzht,vxs,vys,vzs,
     &      vxbt,vybt,vzbt)

      include '../swift.inc'

c...  Inputs:
	integer ntp
	real*8 vxht(NTPMAX),vyht(NTPMAX),vzht(NTPMAX)
        real*8 vxs,vys,vzs

c...  Outputs:
	real*8 vxbt(NTPMAX),vybt(NTPMAX),vzbt(NTPMAX)

c...  Internals:
	integer i

c----
c...  Executable code
	do i=1,ntp
	  vxbt(i) = vxht(i) + vxs
	  vybt(i) = vyht(i) + vys
	  vzbt(i) = vzht(i) + vzs
	enddo

	return
	end     ! coord_vh2b_tp
c--------------------------------------------------------------------------


      SUBROUTINE TCIRC(RP,ES0,I1,I2,ICIRC,TC)
*
*
*     Circularization time.
*     ---------------------
*
*     Theory of Piet Hut, A & A 99, 126 (1981).
*     Developed by Rosemary Mardling (31/1/97).
*     @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
*
      INCLUDE 'common6.h'
      REAL*8  WW(3),QQ(3),W(2),Q(2),AT0(2),M21,WG(2),QG(2),
     &     WSCALE(2),QSCALE(2),A(2),B(2),C(6)
      DATA  WW  /2.119,3.113,8.175/
      DATA  QQ  /0.4909,0.4219,0.2372/
      DATA  A  /6.306505,-7.297806/
      DATA  B  /32.17211,13.01598/
      DATA  C  /5.101417,24.71539,-9.627739,1.733964,
     &     -2.314374,-4.127795/
      DATA  ECCM,ECCM1 /0.002,0.002001/
      SAVE ITIME
      DATA ITIME /0/
*
*
*     Set large circularization time for merged binary.
      IF (RADIUS(I1).EQ.0.0D0.OR.RADIUS(I2).EQ.0.0D0) THEN
         TC = 1.0D+10
         GO TO 30
      END IF
*
*     Specify index J1 as biggest radius to be used with AT0(1).
      IF (RADIUS(I1).GE.RADIUS(I2)) THEN
         J1 = I1
         J2 = I2
      ELSE
         J1 = I2
         J2 = I1
      END IF
*
*     Include an appropriate numerical factor (Chris Tout 07/08).
      AR = RP/((1.0 - ES0)*RADIUS(J1))
      FF = 1.0
      IF (KSTAR(J1).EQ.1.AND.BODY(J1)*SMU.GT.1.25) THEN
         FF = 100.0
      ELSE IF (KSTAR(J1).EQ.4.OR.KSTAR(J1).EQ.7) THEN
         FF = 100.0
      ELSE IF (KSTAR(J1).GE.10) THEN
         FF = 1.0D+17/AR**2
      END IF
      Q12 = BODY(J1)/BODY(J2)
      TAUC = FF*2.0*Q12**2/(1.0 + Q12)*AR**8
*     Exit on TC > 1.0D+08 yr (Chris Tout, Cambody Book 2008).
      IF (TAUC.GT.1.0D+08) THEN
         TC = 1.0D+10
         GO TO 30
      END IF
*
*     Define oscillation period (dimensionless time) and damping constants.
      ZN = 0.0
      DO 5 K = 1,2
         IF (K.EQ.1) THEN
            IK = J1
         ELSE
            IK = J2
         END IF
*     Specify polytropic index for each star (n = 3, 2 or 3/2).
         IF (KSTAR(IK).EQ.3.OR.KSTAR(IK).EQ.5.OR.
     &        KSTAR(IK).EQ.6.OR.KSTAR(IK).EQ.9) THEN
            IPAIR = KVEC(I1)
            CALL GIANT(IPAIR,IK,WG,QG,WSCALE,QSCALE,ZN,QL)
            W(K) = WG(1)
            Q(K) = QG(1)
         ELSE
            QL = 1.0D+04
            IP = 3
            IF (KSTAR(IK).GE.3) IP = 2
            IF (KSTAR(IK).EQ.4.OR.KSTAR(IK).EQ.7) IP = 3
            IF (KSTAR(IK).EQ.8) IP = 3
            IF (KSTAR(IK).EQ.0) IP = 1
            W(K) = WW(IP)
            Q(K) = QQ(IP)
         END IF
         TL = TWOPI*RADIUS(IK)*SQRT(RADIUS(IK)/BODY(IK)/W(K))
         AT0(K) = 1.0/(QL*TL)
    5 CONTINUE
*
*     Form mass, radius & pericentre ratio.
      IF (RADIUS(I1).GE.RADIUS(I2)) THEN
         M21 = BODY(I2)/BODY(I1)
         R21 = RADIUS(I2)/RADIUS(I1)
         RP1 = RP/RADIUS(I1)
      ELSE
         M21 = BODY(I1)/BODY(I2)
         R21 = RADIUS(I1)/RADIUS(I2)
         RP1 = RP/RADIUS(I2)
      END IF
*
*     Evaluate damping coefficient.
      RR = RP1*(1.0 + ES0)
      CONST = 2.0*(AT0(1)*(Q(1)/W(1))**2*(1.0 + M21)*M21 +
     &     AT0(2)*(Q(2)/W(2))**2*((1.0 + M21)/M21**2)*R21**8)/
     &     RR**8
*
*     Adopt WD scaling for any NS to avoid numerical problem.
      IF (KSTAR(I1).EQ.13.OR.KSTAR(I2).EQ.13) THEN
         CONST = 1.0D-04*CONST
      END IF
*
*     Form rational function approximation to Hut solution.
      FF = (( A(2)*ES0 + A(1))*ES0 + 1.0 )/
     &     (( B(2)*ES0 + B(1))*ES0 + 1.0 )
*     FF = MIN(FF,0.999D0)
*
*     See whether we only want the modified eccentricity (routine BINPOP).
      IF (ICIRC.LE.0) GO TO 10
*
      TIME0 = 0.0
*     Obtain the new eccentricity.
      Z = (TIME - TIME0)*CONST + FF
      ECC = (-1.0 + C(1)*Z - SQRT(C(2)*Z**2 + C(3)*Z + C(4)))
     &     /(C(5) + C(6)*Z)
*
      ECC = MAX(ECC,ECCM)
      RP = RP*(1.0 + ES0)/(1.0 + ECC)
      ES0 = ECC
      GO TO 30
*
*     Evaluate circularization time (in units of 10**6 yrs).
 10   TC = TSTAR*(1.0 - FF)/CONST
*
*     Activate tidal indicator if TC < 2x10**9 yrs or hyperbolic orbit.
      IF (TC.LT.2000.0.OR.ES0.GT.1.0) THEN
         IP = KVEC(I1)
         ITIME = ITIME + 1
*     Note possibility of counter exceeding the limit.
         IF (ITIME.GT.2000000000) ITIME = 0
         IF (ICIRC.EQ.0.AND.KZ(27).EQ.2.AND.ITIME.LT.100) THEN
            SEMI = -0.5*BODY(N+IP)/H(IP)
            if(rank.eq.0)then
               WRITE (6,20)  I1, NCHAOS, ES0, RP1, M21, TC, SEMI, ZN
 20            FORMAT (' TCIRC:    I1 NCH E RP M21 TC A n ',
     &              2I5,F8.4,F8.1,F6.2,1P,2E10.2,0P,F5.1)
            end if
         END IF
         ICIRC = 1
*     Define Roche search indicator for circularized orbit (ECCM1 > 0.002).
         IF (ES0.LE.ECCM1.AND.KSTAR(N+IP).EQ.0) THEN
            KSTAR(N+IP) = 10
         END IF
      ELSE
*     Note ICIRC = -1 for some calls.
         ICIRC = 0
      END IF
*
 30   RETURN
*
      END


      subroutine qzhes(nm,n,a,b,matz,z)
c
      integer i,j,k,l,n,lb,l1,nm,nk1,nm1,nm2
      double precision a(nm,n),b(nm,n),z(nm,n)
      double precision r,s,t,u1,u2,v1,v2,rho
      logical matz
c
c     this subroutine is the first step of the qz algorithm
c     for solving generalized matrix eigenvalue problems,
c     siam j. numer. anal. 10, 241-256(1973) by moler and stewart.
c
c     this subroutine accepts a pair of real general matrices and
c     reduces one of them to upper hessenberg form and the other
c     to upper triangular form using orthogonal transformations.
c     it is usually followed by  qzit,  qzval  and, possibly,  qzvec.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrices.
c
c        a contains a real general matrix.
c
c        b contains a real general matrix.
c
c        matz should be set to .true. if the right hand transformations
c          are to be accumulated for later use in computing
c          eigenvectors, and to .false. otherwise.
c
c     on output
c
c        a has been reduced to upper hessenberg form.  the elements
c          below the first subdiagonal have been set to zero.
c
c        b has been reduced to upper triangular form.  the elements
c          below the main diagonal have been set to zero.
c
c        z contains the product of the right hand transformations if
c          matz has been set to .true.  otherwise, z is not referenced.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
c     .......... initialize z ..........
      if (.not. matz) go to 10
c
      do 3 j = 1, n
c
         do 2 i = 1, n
            z(i,j) = 0.0d0
    2    continue
c
         z(j,j) = 1.0d0
    3 continue
c     .......... reduce b to upper triangular form ..........
   10 if (n .le. 1) go to 170
      nm1 = n - 1
c
      do 100 l = 1, nm1
         l1 = l + 1
         s = 0.0d0
c
         do 20 i = l1, n
            s = s + dabs(b(i,l))
   20    continue
c
         if (s .eq. 0.0d0) go to 100
         s = s + dabs(b(l,l))
         r = 0.0d0
c
         do 25 i = l, n
            b(i,l) = b(i,l) / s
            r = r + b(i,l)**2
   25    continue
c
         r = dsign(dsqrt(r),b(l,l))
         b(l,l) = b(l,l) + r
         rho = r * b(l,l)
c
         do 50 j = l1, n
            t = 0.0d0
c
            do 30 i = l, n
               t = t + b(i,l) * b(i,j)
   30       continue
c
            t = -t / rho
c
            do 40 i = l, n
               b(i,j) = b(i,j) + t * b(i,l)
   40       continue
c
   50    continue
c
         do 80 j = 1, n
            t = 0.0d0
c
            do 60 i = l, n
               t = t + b(i,l) * a(i,j)
   60       continue
c
            t = -t / rho
c
            do 70 i = l, n
               a(i,j) = a(i,j) + t * b(i,l)
   70       continue
c
   80    continue
c
         b(l,l) = -s * r
c
         do 90 i = l1, n
            b(i,l) = 0.0d0
   90    continue
c
  100 continue
c     .......... reduce a to upper hessenberg form, while
c                keeping b triangular ..........
      if (n .eq. 2) go to 170
      nm2 = n - 2
c
      do 160 k = 1, nm2
         nk1 = nm1 - k
c     .......... for l=n-1 step -1 until k+1 do -- ..........
         do 150 lb = 1, nk1
            l = n - lb
            l1 = l + 1
c     .......... zero a(l+1,k) ..........
            s = dabs(a(l,k)) + dabs(a(l1,k))
            if (s .eq. 0.0d0) go to 150
            u1 = a(l,k) / s
            u2 = a(l1,k) / s
            r = dsign(dsqrt(u1*u1+u2*u2),u1)
            v1 =  -(u1 + r) / r
            v2 = -u2 / r
            u2 = v2 / v1
c
            do 110 j = k, n
               t = a(l,j) + u2 * a(l1,j)
               a(l,j) = a(l,j) + t * v1
               a(l1,j) = a(l1,j) + t * v2
  110       continue
c
            a(l1,k) = 0.0d0
c
            do 120 j = l, n
               t = b(l,j) + u2 * b(l1,j)
               b(l,j) = b(l,j) + t * v1
               b(l1,j) = b(l1,j) + t * v2
  120       continue
c     .......... zero b(l+1,l) ..........
            s = dabs(b(l1,l1)) + dabs(b(l1,l))
            if (s .eq. 0.0d0) go to 150
            u1 = b(l1,l1) / s
            u2 = b(l1,l) / s
            r = dsign(dsqrt(u1*u1+u2*u2),u1)
            v1 =  -(u1 + r) / r
            v2 = -u2 / r
            u2 = v2 / v1
c
            do 130 i = 1, l1
               t = b(i,l1) + u2 * b(i,l)
               b(i,l1) = b(i,l1) + t * v1
               b(i,l) = b(i,l) + t * v2
  130       continue
c
            b(l1,l) = 0.0d0
c
            do 140 i = 1, n
               t = a(i,l1) + u2 * a(i,l)
               a(i,l1) = a(i,l1) + t * v1
               a(i,l) = a(i,l) + t * v2
  140       continue
c
            if (.not. matz) go to 150
c
            do 145 i = 1, n
               t = z(i,l1) + u2 * z(i,l)
               z(i,l1) = z(i,l1) + t * v1
               z(i,l) = z(i,l) + t * v2
  145       continue
c
  150    continue
c
  160 continue
c
  170 return
      end


        SUBROUTINE FIXPQS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,
     &     A,NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,PP,RHOVEC,Z0,DZ,
     &     T,WORK,SSPAR,PAR,IPAR)
C
C SUBROUTINE  FIXPQS  FINDS A FIXED POINT OR ZERO OF THE
C N-DIMENSIONAL VECTOR FUNCTION  F(X), OR TRACKS A ZERO CURVE OF A
C GENERAL HOMOTOPY MAP  RHO(A,X,LAMBDA).  FOR THE FIXED POINT PROBLEM
C F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL INTO ITSELF.  THE
C EQUATION  X=F(X)  IS SOLVED BY FOLLOWING THE ZERO CURVE OF THE
C HOMOTOPY MAP
C
C  LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A),
C
C STARTING FROM  LAMBDA = 0, X = A.   THE CURVE IS PARAMETERIZED
C BY ARC LENGTH  S, AND IS FOLLOWED BY SOLVING THE ORDINARY
C DIFFERENTIAL EQUATION  D(HOMOTOPY MAP)/DS = 0  FOR
C Y(S) = (X(S),LAMBDA(S)).  THIS IS DONE BY USING A HERMITE CUBIC
C PREDICTOR AND A CORRECTOR WHICH RETURNS TO THE ZERO CURVE IN A
C HYPERPLANE PERPENDICULAR TO THE TANGENT TO THE ZERO CURVE AT THE
C MOST RECENT POINT.
C
C FOR THE ZERO FINDING PROBLEM  F(X)  IS ASSUMED TO BE A C2 MAP SUCH
C THAT FOR SOME  R > 0,  X*F(X) >= 0  WHENEVER  NORM(X) = R.
C THE EQUATION  F(X) = 0  IS SOLVED BY FOLLOWING THE ZERO CURVE OF
C THE HOMOTOPY MAP
C
C  LAMBDA*F(X) + (1 - LAMBDA)*(X - A)
C
C EMANATING FROM  LAMBDA = 0, X = A.
C
C A  MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS.
C
C FOR THE CURVE TRACKING PROBLEM RHO(A,X,LAMBDA) IS ASSUMED TO
C BE A C2 MAP FROM  E**M X [0,1) X E**N  INTO  E**N, WHICH FOR
C ALMOST ALL PARAMETER VECTORS  A  IN SOME NONEMPTY OPEN SUBSET
C OF E**M SATISFIES
C
C  RANK [D RHO(A,X,LAMBDA)/D LAMBDA, D RHO(A,X,LAMBDA)/DX] = N
C
C FOR ALL POINTS  (X,LAMBDA)  SUCH THAT  RHO(A,X,LAMBDA) = 0.  IT IS
C FURTHER ASSUMED THAT
C
C         RANK [ D RHO(A,X0,0)/DX ] = N.
C
C WITH  A  FIXED, THE ZERO CURVE OF  RHO(A,X,LAMBDA)  EMANATING FROM
C LAMBDA = 0, X = X0  IS TRACKED UNTIL  LAMBDA = 1  BY SOLVING THE
C ORDINARY DIFFERENTIAL EQUATION  D RHO(A,X(S),LAMBDA(S))/DS = 0
C FOR  Y(S) = (X(S),LAMBDA(S)), WHERE  S  IS ARC LENGTH ALONG THE
C ZERO CURVE.  ALSO THE HOMOTOPY MAP  RHO(A,X,LAMBDA)  IS ASSUMED TO
C BE CONSTRUCTED SUCH THAT
C
C         D LAMBDA(0)/DS > 0.
C
C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER MUST SUPPLY
C A SUBROUTINE  F(X,V)  WHICH EVALUATES F(X) AT X AND RETURNS THE
C VECTOR F(X) IN  V,  AND A SUBROUTINE  FJACS(X,QR,LENQR,PIVOT)  WHICH
C EVALUATES THE (SYMMETRIC) JACOBIAN MATRIX OF F(X) AT X, AND RETURNS
C THE SYMMETRIC JACOBIAN MATRIX IN PACKED SKYLINE STORAGE FORMAT IN  QR.
C LENQR  AND  PIVOT  DESCRIBE THE DATA STRUCTURE IN  QR.  FOR THE CURVE
C TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE
C  RHO(A,LAMBDA,X,V,PAR,IPAR)  WHICH EVALUATES THE HOMOTOPY MAP RHO
C AT (A,X,LAMBDA) AND RETURNS THE VECTOR RHO(A,X,LAMBDA) IN  V,
C AND A SUBROUTINE  RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR)  WHICH
C RETURNS IN  QR  THE SYMMETRIC N X N JACOBIAN MATRIX [D RHO/DX]
C EVALUATED AT (A,X,LAMBDA) AND STORED IN PACKED SKYLINE FORMAT,
C AND RETURNS IN  PP  THE VECTOR  -(D RHO/D LAMBDA)  EVALUATED AT
C (A,X,LAMBDA).  LENQR  AND  PIVOT  DESCRIBE THE DATA STRUCTURE IN
C QR.
C *** NOTE THE MINUS SIGN IN THE DEFINITION OF  PP. ***
C
C
C FIXPQS DIRECTLY OR INDIRECTLY USES THE SUBROUTINES  D1MACH, F
C (OR RHO), FJACS (OR RHOJS), GMFADS, MULTDS, PCGQS, ROOTQS, STEPQS,
C SOLVDS,  AND THE BLAS ROUTINES  DAXPY, DCOPY, DDOT, DNRM2, AND  DSCAL.
C ONLY  D1MACH  CONTAINS MACHINE DEPENDENT CONSTANTS.  NO OTHER
C MODIFICATIONS BY THE USER ARE REQUIRED.
C
C
C ON INPUT:
C
C N  IS THE DIMENSION OF X, F(X), AND RHO(A,X,LAMBDA).
C
C Y(1:N+1)  CONTAINS THE STARTING POINT FOR TRACKING THE HOMOTOPY MAP.
C    (Y(1),...,Y(N)) = A  FOR THE FIXED POINT AND ZERO FINDING
C    PROBLEMS.  (Y(1),...,Y(N)) = X0  FOR THE CURVE TRACKING PROBLEM.
C    Y(N+1)  NEED NOT BE DEFINED BY THE USER.
C
C IFLAG  CAN BE -2, -1, 0, 2, OR 3.  IFLAG  SHOULD BE 0 ON THE FIRST
C    CALL TO  FIXPQS  FOR THE PROBLEM  X=F(X), -1 FOR THE PROBLEM
C    F(X)=0, AND -2 FOR THE PROBLEM  RHO(A,X,LAMBDA)=0.   IN CERTAIN
C    SITUATIONS  IFLAG  IS SET TO 2 OR 3 BY  FIXPQS, AND  FIXPQS  CAN
C    BE CALLED AGAIN WITHOUT CHANGING  IFLAG.
C
C ARCRE, ARCAE  ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY,
C    ALLOWED THE ITERATION ALONG THE ZERO CURVE.  IF
C    ARC?E .LE. 0.0  ON INPUT, IT IS RESET TO  .5*SQRT(ANS?E).
C    NORMALLY  ARC?E  SHOULD BE CONSIDERABLY LARGER THAN  ANS?E.
C
C ANSRE, ANSAE  ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR
C    THE ANSWER AT  LAMBDA = 1.  THE ACCEPTED ANSWER  Y = (X,LAMBDA)
C    SATISFIES
C
C      |Y(1) - 1| .LE. ANSRE + ANSAE      .AND.
C
C      ||DZ|| .LE. ANSRE*||Y|| + ANSAE      WHERE
C
C      DZ IS THE NEWTON STEP TO Y.
C
C TRACE  IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR
C    INTERMEDIATE OUTPUT.  IF  TRACE .GT. 0  THE POINTS COMPUTED ON
C    THE ZERO CURVE ARE WRITTEN TO I/O UNIT  TRACE .
C
C A(1:*)  CONTAINS THE PARAMETER VECTOR  A.  FOR THE FIXED POINT
C    AND ZERO FINDING PROBLEMS,  A  NEED NOT BE INITIALIZED BY THE
C    USER, AND IS ASSUMED TO HAVE LENGTH  N.  FOR THE CURVE
C    TRACKING PROBLEM,  A  MUST BE INITIALIZED BY THE USER.
C
C YP(1:N+1)  IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO THE
C    ZERO CURVE AT THE CURRENT POINT  Y.
C
C YOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND
C    ON THE ZERO CURVE.
C
C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO
C    THE ZERO CURVE AT  YOLD.
C
C QR(1:LENQR)  IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC
C    JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE
C    STORAGE FORMAT.  LENQR  AND  PIVOT  DESCRIBE THE DATA
C    STRUCTURE IN  QR.  (SEE SUBROUTINE  PCGQS  FOR A DESCRIPTION
C    OF THIS DATA STRUCTURE).
C
C LENQR  IS THE LENGTH OF THE N-DIMENSIONAL ARRAY  QR.  I.E.
C    IT IS THE NUMBER OF NON-ZERO ENTRIES IN THE JACOBIAN
C    MATRIX [DF/DX] (OR [D RHO/DX]).
C
C PIVOT(1:N+2)  IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAIN
C    THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC
C    JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN  QR.
C
C PP(1:N)  IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN
C    OF THE JACOBIAN MATRIX  -[D RHO/D LAMBDA].
C
C RHOVEC(1:N+1), Z0(1:N+1), DZ(1:N+1), T(1:N+1)  ARE ALL WORK ARRAYS
C    USED BY  STEPQS, TANGQS, AND ROOTQS  TO CALCULATE THE TANGENT
C    VECTORS AND NEWTON STEPS.
C
C WORK(1:8*(N+1)+LENQR)  IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT
C    ALGORITHM TO SOLVE LINEAR SYSTEMS.
C
C SSPAR(1:4) =  (HMIN, HMAX, BMIN, BMAX)  IS A VECTOR OF PARAMETERS
C    USED FOR THE OPTIMAL STEP SIZE ESTIMATION.  A DEFAULT VALUE
C    CAN BE SPECIFIED FOR ANY OF THESE FOUR PARAMETERS BY SETTING IT
C    .LE. 0.0  ON INPUT.  SEE THE COMMENTS IN  STEPQS  FOR MORE
C    INFORMATION ABOUT THESE PARAMETERS.
C
C PAR(1:*)  AND  IPAR(1:*)  ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS,
C    WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES
C    RHO, RHOJS.
C
C
C ON OUTPUT:
C
C N , TRACE , A , LENQR  ARE UNCHANGED.
C
C Y(N+1) = LAMBDA, (Y(1),...,Y(N)) = X, AND  Y  IS AN APPROXIMATE
C    ZERO OF THE HOMOTOPY MAP.  NORMALLY  LAMBDA = 1  AND  X  IS A
C    FIXED POINT OR ZERO OF  F(X).   IN ABNORMAL SITUATIONS,  LAMBDA
C    MAY ONLY BE NEAR 1 AND  X  NEAR A FIXED POINT OR ZERO.
C
C IFLAG =
C
C   1   NORMAL RETURN.
C
C   2   SPECIFIED ERROR TOLERANCE CANNOT BE MET.  SOME OR ALL OF
C       ARCRE, ARCAE, ANSRE, ANSAE  HAVE BEEN INCREASED TO
C       SUITABLE VALUES.  TO CONTINUE, JUST CALL  FIXPQS  AGAIN
C       WITHOUT CHANGING ANY PARAMETERS.
C
C   3   STEPQS  HAS BEEN CALLED 1000 TIMES.  TO CONTINUE, CALL
C       FIXPQS  AGAIN WITHOUT CHANGING ANY PARAMETERS.
C
C   4   JACOBIAN MATRIX DOES NOT HAVE FULL RANK.  THE ALGORITHM
C       HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE
C       FOLLOWED ANY FURTHER).
C
C   5   THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE
C       HOMOTOPY MAP AND IS NOT MAKING PROGRESS.  THE ERROR
C       TOLERANCES  ARC?E  AND  ANS?E  WERE TOO LENIENT.  THE PROBLEM
C       SHOULD BE RESTRARTED BY CALLING  FIXPQS  WITH SMALLER ERROR
C       TOLERANCES AND  IFLAG = 0 (-1, -2).
C
C   6   THE NEWTON ITERATION IN  STEPQS  OR  ROOTQS  FAILED TO
C       CONVERGE.  THE ERROR TOLERANCES  ANS?E  MAY BE TOO STRINGENT.
C
C   7   ILLEGAL INPUT PARAMETERS, A FATAL ERROR.
C
C ARCRE, ARCAE, ANSRE, ANSAE  ARE UNCHANGED AFTER A NORMAL RETURN
C    (IFLAG = 1).  THEY ARE INCREASED TO APPROPRIATE VALUES ON THE
C    RETURN  IFLAG = 2.
C
C NFE  IS THE NUMBER OF JACOBIAN EVALUATIONS.
C
C ARCLEN  IS THE APPROXIMATE LENGTH OF THE ZERO CURVE.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION ABSERR, H, HOLD, RELERR, S, WK
        INTEGER IFLAGC, ITER, JW, LIMITD, LIMIT, NP1, PCGWK
        LOGICAL CRASH, START
C
C     SCALAR ARGUMENTS
C
        DOUBLE PRECISION ARCRE, ARCAE, ANSRE, ANSAE, ARCLEN
        INTEGER N, IFLAG, TRACE, NFE, LENQR
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION A(N), Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1),
     &    QR(LENQR), PP(N), RHOVEC(N+1), Z0(N+1), DZ(N+1), T(N+1),
     &    WORK(8*(N+1)+LENQR), SSPAR(4), PAR(1)
        INTEGER PIVOT(N+2), IPAR(1)
C
        SAVE
C
C ***** END OF DECLARATIONS *****
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
        PARAMETER (LIMITD =1000)
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C CHECK IFLAG
C
        IF (N .LE. 0 .OR. ANSRE .LE. 0.0 .OR. ANSAE .LT. 0.0)
     &    IFLAG = 7
        IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 10
        IF (IFLAG .EQ. 2) GO TO 50
        IF (IFLAG .EQ. 3) GO TO 40
C
C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3.
C
        IFLAG = 7
        RETURN
C
C ***** INITIALIZATION BLOCK  *****
C
  10    ARCLEN = 0.0
        IF (ARCRE .LE. 0.0) ARCRE = .5*SQRT(ANSRE)
        IF (ARCAE .LE. 0.0) ARCAE = .5*SQRT(ANSAE)
        NFE=0
        IFLAGC = IFLAG
        NP1=N+1
        PCGWK = 2*N+3
C
C SET INITIAL CONDITIONS FOR FIRST CALL TO STEPQS.
C
        START=.TRUE.
        CRASH=.FALSE.
        RELERR = ARCRE
        ABSERR = ARCAE
        HOLD=1.0
        H=0.1
        S=0.0
        YPOLD(NP1) = 1.0
        Y(NP1) = 0.0
        DO 20 JW=1,N
          YPOLD(JW)=0.0
  20    CONTINUE
C
C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS.
C
C     MINIMUM STEP SIZE HMIN
        IF (SSPAR(1) .LE. 0.0) SSPAR(1)= (SQRT(N+1.0)+4.0)*D1MACH(4)
C     MAXIMUM STEP SIZE HMAX
        IF (SSPAR(2) .LE. 0.0) SSPAR(2)= 1.0
C     MINIMUM STEP REDUCTION FACTOR BMIN
        IF (SSPAR(3) .LE. 0.0) SSPAR(3)= 0.1
C     MAXIMUM STEP EXPANSION FACTOR BMAX
        IF (SSPAR(4) .LE. 0.0) SSPAR(4)= 7.0
C
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
C
        IF (IFLAGC .GE. -1) THEN
          CALL DCOPY(N,Y,1,A,1)
        ENDIF
C
  40    LIMIT=LIMITD
C
C ***** END OF INITIALIZATION BLOCK. *****
C
C ***** MAIN LOOP. *****
C
  50    DO 400 ITER=1,LIMIT
        IF (Y(NP1) .LT. 0.0) THEN
          ARCLEN = S
          IFLAG = 5
          RETURN
        END IF
C
C TAKE A STEP ALONG THE CURVE.
C
        CALL STEPQS(N,NFE,IFLAGC,LENQR,START,CRASH,HOLD,H,WK,RELERR,
     &    ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,PIVOT,PP,RHOVEC,Z0,DZ,T,
     &    WORK,SSPAR,PAR,IPAR)
C
C PRINT LATEST POINT ON CURVE IF REQUESTED.
C
      IF (TRACE .GT. 0) THEN
	WRITE (TRACE,217) ITER,NFE,S,Y(NP1),(Y(JW),JW=1,N)
217     FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X,
     &  'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4))
      ENDIF
C
C CHECK IF THE STEP WAS SUCCESSFUL.
C
        IF (IFLAGC .GT. 0) THEN
          ARCLEN=S
          IFLAG=IFLAGC
          RETURN
        END IF
C
        IF (CRASH) THEN
C
C         RETURN CODE FOR ERROR TOLERANCE TOO SMALL.
C
          IFLAG=2
C
C         CHANGE ERROR TOLERANCES.
C
          IF (ARCRE .LT. RELERR) THEN
            ARCRE=RELERR
            ANSRE=RELERR
          ENDIF
          IF (ARCAE .LT. ABSERR) ARCAE=ABSERR
C
C         CHANGE LIMIT ON NUMBER OF ITERATIONS.
C
          LIMIT = LIMIT - ITER
          RETURN
        END IF
C
C IF  LAMBDA >= 1.0,  USE  ROOTQS  TO FIND SOLUTION.
C
        IF (Y(NP1) .GE. 1.0) GOTO 500
C
  400   CONTINUE
C
C ***** END OF MAIN LOOP *****
C
C DID NOT CONVERGE IN  LIMIT  ITERATIONS, SET  IFLAG  AND RETURN.
C
        ARCLEN = S
        IFLAG = 3
        RETURN
C
C ***** FINAL STEP -- FIND SOLUTION AT LAMBDA=1 *****
C
C SAVE  YOLD  FOR ARC LENGTH CALCULATION LATER.
C
  500   CALL DCOPY(NP1,YOLD,1,T,1)
C
C FIND SOLUTION.
C
        CALL ROOTQS(N,NFE,IFLAGC,LENQR,ANSRE,ANSAE,Y,YP,YOLD,YPOLD,
     &    A,QR,PIVOT,PP,RHOVEC,Z0,DZ,WORK(PCGWK),PAR,IPAR)
C
C CHECK IF SOLUTION WAS FOUND AND SET  IFLAG  ACCORDINGLY.
C
        IFLAG=1
C
C     SET ERROR FLAG IF ROOTQS COULD NOT GET THE POINT ON THE ZERO
C     CURVE AT  LAMBDA = 1.0 .
C
        IF (IFLAGC .GT. 0) IFLAG=IFLAGC
C
C CALCULATE FINAL ARC LENGTH.
C
        CALL DCOPY(NP1,Y,1,DZ,1)
        WK=-1.0
        CALL DAXPY(NP1,WK,T,1,DZ,1)
        ARCLEN=S - HOLD + DNRM2(NP1,DZ,1)
C
C ***** END OF FINAL STEP *****
C
        RETURN
C
C ***** END OF SUBROUTINE FIXPQS *****
        END


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

      subroutine matvec_sub(ablock,avec,bvec)

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

!---------------------------------------------------------------------
!     subtracts bvec=bvec - ablock*avec
!---------------------------------------------------------------------

      implicit none

      double precision ablock,avec,bvec
      dimension ablock(5,5),avec(5),bvec(5)

!---------------------------------------------------------------------
!            rhs(i,ic,jc,kc,ccell) = rhs(i,ic,jc,kc,ccell)
!     $           - lhs(i,1,ablock,ia,ja,ka,acell)*
!---------------------------------------------------------------------
         bvec(1) = bvec(1) - ablock(1,1)*avec(1)  &
     &                     - ablock(1,2)*avec(2)  &
     &                     - ablock(1,3)*avec(3)  &
     &                     - ablock(1,4)*avec(4)  &
     &                     - ablock(1,5)*avec(5)
         bvec(2) = bvec(2) - ablock(2,1)*avec(1)  &
     &                     - ablock(2,2)*avec(2)  &
     &                     - ablock(2,3)*avec(3)  &
     &                     - ablock(2,4)*avec(4)  &
     &                     - ablock(2,5)*avec(5)
         bvec(3) = bvec(3) - ablock(3,1)*avec(1)  &
     &                     - ablock(3,2)*avec(2)  &
     &                     - ablock(3,3)*avec(3)  &
     &                     - ablock(3,4)*avec(4)  &
     &                     - ablock(3,5)*avec(5)
         bvec(4) = bvec(4) - ablock(4,1)*avec(1)  &
     &                     - ablock(4,2)*avec(2)  &
     &                     - ablock(4,3)*avec(3)  &
     &                     - ablock(4,4)*avec(4)  &
     &                     - ablock(4,5)*avec(5)
         bvec(5) = bvec(5) - ablock(5,1)*avec(1)  &
     &                     - ablock(5,2)*avec(2)  &
     &                     - ablock(5,3)*avec(3)  &
     &                     - ablock(5,4)*avec(4)  &
     &                     - ablock(5,5)*avec(5)

      return
      end

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

      subroutine matmul_sub(ablock, bblock, cblock)

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

!---------------------------------------------------------------------
!     subtracts a(i,j,k) X b(i,j,k) from c(i,j,k)
!---------------------------------------------------------------------

      implicit none

      double precision ablock, bblock, cblock
      dimension ablock(5,5), bblock(5,5), cblock(5,5)

         cblock(1,1) = cblock(1,1) - ablock(1,1)*bblock(1,1)  &
     &                             - ablock(1,2)*bblock(2,1)  &
     &                             - ablock(1,3)*bblock(3,1)  &
     &                             - ablock(1,4)*bblock(4,1)  &
     &                             - ablock(1,5)*bblock(5,1)
         cblock(2,1) = cblock(2,1) - ablock(2,1)*bblock(1,1)  &
     &                             - ablock(2,2)*bblock(2,1)  &
     &                             - ablock(2,3)*bblock(3,1)  &
     &                             - ablock(2,4)*bblock(4,1)  &
     &                             - ablock(2,5)*bblock(5,1)
         cblock(3,1) = cblock(3,1) - ablock(3,1)*bblock(1,1)  &
     &                             - ablock(3,2)*bblock(2,1)  &
     &                             - ablock(3,3)*bblock(3,1)  &
     &                             - ablock(3,4)*bblock(4,1)  &
     &                             - ablock(3,5)*bblock(5,1)
         cblock(4,1) = cblock(4,1) - ablock(4,1)*bblock(1,1)  &
     &                             - ablock(4,2)*bblock(2,1)  &
     &                             - ablock(4,3)*bblock(3,1)  &
     &                             - ablock(4,4)*bblock(4,1)  &
     &                             - ablock(4,5)*bblock(5,1)
         cblock(5,1) = cblock(5,1) - ablock(5,1)*bblock(1,1)  &
     &                             - ablock(5,2)*bblock(2,1)  &
     &                             - ablock(5,3)*bblock(3,1)  &
     &                             - ablock(5,4)*bblock(4,1)  &
     &                             - ablock(5,5)*bblock(5,1)
         cblock(1,2) = cblock(1,2) - ablock(1,1)*bblock(1,2)  &
     &                             - ablock(1,2)*bblock(2,2)  &
     &                             - ablock(1,3)*bblock(3,2)  &
     &                             - ablock(1,4)*bblock(4,2)  &
     &                             - ablock(1,5)*bblock(5,2)
         cblock(2,2) = cblock(2,2) - ablock(2,1)*bblock(1,2)  &
     &                             - ablock(2,2)*bblock(2,2)  &
     &                             - ablock(2,3)*bblock(3,2)  &
     &                             - ablock(2,4)*bblock(4,2)  &
     &                             - ablock(2,5)*bblock(5,2)
         cblock(3,2) = cblock(3,2) - ablock(3,1)*bblock(1,2)  &
     &                             - ablock(3,2)*bblock(2,2)  &
     &                             - ablock(3,3)*bblock(3,2)  &
     &                             - ablock(3,4)*bblock(4,2)  &
     &                             - ablock(3,5)*bblock(5,2)
         cblock(4,2) = cblock(4,2) - ablock(4,1)*bblock(1,2)  &
     &                             - ablock(4,2)*bblock(2,2)  &
     &                             - ablock(4,3)*bblock(3,2)  &
     &                             - ablock(4,4)*bblock(4,2)  &
     &                             - ablock(4,5)*bblock(5,2)
         cblock(5,2) = cblock(5,2) - ablock(5,1)*bblock(1,2)  &
     &                             - ablock(5,2)*bblock(2,2)  &
     &                             - ablock(5,3)*bblock(3,2)  &
     &                             - ablock(5,4)*bblock(4,2)  &
     &                             - ablock(5,5)*bblock(5,2)
         cblock(1,3) = cblock(1,3) - ablock(1,1)*bblock(1,3)  &
     &                             - ablock(1,2)*bblock(2,3)  &
     &                             - ablock(1,3)*bblock(3,3)  &
     &                             - ablock(1,4)*bblock(4,3)  &
     &                             - ablock(1,5)*bblock(5,3)
         cblock(2,3) = cblock(2,3) - ablock(2,1)*bblock(1,3)  &
     &                             - ablock(2,2)*bblock(2,3)  &
     &                             - ablock(2,3)*bblock(3,3)  &
     &                             - ablock(2,4)*bblock(4,3)  &
     &                             - ablock(2,5)*bblock(5,3)
         cblock(3,3) = cblock(3,3) - ablock(3,1)*bblock(1,3)  &
     &                             - ablock(3,2)*bblock(2,3)  &
     &                             - ablock(3,3)*bblock(3,3)  &
     &                             - ablock(3,4)*bblock(4,3)  &
     &                             - ablock(3,5)*bblock(5,3)
         cblock(4,3) = cblock(4,3) - ablock(4,1)*bblock(1,3)  &
     &                             - ablock(4,2)*bblock(2,3)  &
     &                             - ablock(4,3)*bblock(3,3)  &
     &                             - ablock(4,4)*bblock(4,3)  &
     &                             - ablock(4,5)*bblock(5,3)
         cblock(5,3) = cblock(5,3) - ablock(5,1)*bblock(1,3)  &
     &                             - ablock(5,2)*bblock(2,3)  &
     &                             - ablock(5,3)*bblock(3,3)  &
     &                             - ablock(5,4)*bblock(4,3)  &
     &                             - ablock(5,5)*bblock(5,3)
         cblock(1,4) = cblock(1,4) - ablock(1,1)*bblock(1,4)  &
     &                             - ablock(1,2)*bblock(2,4)  &
     &                             - ablock(1,3)*bblock(3,4)  &
     &                             - ablock(1,4)*bblock(4,4)  &
     &                             - ablock(1,5)*bblock(5,4)
         cblock(2,4) = cblock(2,4) - ablock(2,1)*bblock(1,4)  &
     &                             - ablock(2,2)*bblock(2,4)  &
     &                             - ablock(2,3)*bblock(3,4)  &
     &                             - ablock(2,4)*bblock(4,4)  &
     &                             - ablock(2,5)*bblock(5,4)
         cblock(3,4) = cblock(3,4) - ablock(3,1)*bblock(1,4)  &
     &                             - ablock(3,2)*bblock(2,4)  &
     &                             - ablock(3,3)*bblock(3,4)  &
     &                             - ablock(3,4)*bblock(4,4)  &
     &                             - ablock(3,5)*bblock(5,4)
         cblock(4,4) = cblock(4,4) - ablock(4,1)*bblock(1,4)  &
     &                             - ablock(4,2)*bblock(2,4)  &
     &                             - ablock(4,3)*bblock(3,4)  &
     &                             - ablock(4,4)*bblock(4,4)  &
     &                             - ablock(4,5)*bblock(5,4)
         cblock(5,4) = cblock(5,4) - ablock(5,1)*bblock(1,4)  &
     &                             - ablock(5,2)*bblock(2,4)  &
     &                             - ablock(5,3)*bblock(3,4)  &
     &                             - ablock(5,4)*bblock(4,4)  &
     &                             - ablock(5,5)*bblock(5,4)
         cblock(1,5) = cblock(1,5) - ablock(1,1)*bblock(1,5)  &
     &                             - ablock(1,2)*bblock(2,5)  &
     &                             - ablock(1,3)*bblock(3,5)  &
     &                             - ablock(1,4)*bblock(4,5)  &
     &                             - ablock(1,5)*bblock(5,5)
         cblock(2,5) = cblock(2,5) - ablock(2,1)*bblock(1,5)  &
     &                             - ablock(2,2)*bblock(2,5)  &
     &                             - ablock(2,3)*bblock(3,5)  &
     &                             - ablock(2,4)*bblock(4,5)  &
     &                             - ablock(2,5)*bblock(5,5)
         cblock(3,5) = cblock(3,5) - ablock(3,1)*bblock(1,5)  &
     &                             - ablock(3,2)*bblock(2,5)  &
     &                             - ablock(3,3)*bblock(3,5)  &
     &                             - ablock(3,4)*bblock(4,5)  &
     &                             - ablock(3,5)*bblock(5,5)
         cblock(4,5) = cblock(4,5) - ablock(4,1)*bblock(1,5)  &
     &                             - ablock(4,2)*bblock(2,5)  &
     &                             - ablock(4,3)*bblock(3,5)  &
     &                             - ablock(4,4)*bblock(4,5)  &
     &                             - ablock(4,5)*bblock(5,5)
         cblock(5,5) = cblock(5,5) - ablock(5,1)*bblock(1,5)  &
     &                             - ablock(5,2)*bblock(2,5)  &
     &                             - ablock(5,3)*bblock(3,5)  &
     &                             - ablock(5,4)*bblock(4,5)  &
     &                             - ablock(5,5)*bblock(5,5)

      return
      end

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

      subroutine binvcrhs( lhs,c,r )

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

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

      implicit none

      double precision pivot, coeff, lhs
      dimension lhs(5,5)
      double precision c(5,5), r(5)

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

      pivot = 1.00d0/lhs(1,1)
      lhs(1,2) = lhs(1,2)*pivot
      lhs(1,3) = lhs(1,3)*pivot
      lhs(1,4) = lhs(1,4)*pivot
      lhs(1,5) = lhs(1,5)*pivot
      c(1,1) = c(1,1)*pivot
      c(1,2) = c(1,2)*pivot
      c(1,3) = c(1,3)*pivot
      c(1,4) = c(1,4)*pivot
      c(1,5) = c(1,5)*pivot
      r(1)   = r(1)  *pivot

      coeff = lhs(2,1)
      lhs(2,2)= lhs(2,2) - coeff*lhs(1,2)
      lhs(2,3)= lhs(2,3) - coeff*lhs(1,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(1,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(1,5)
      c(2,1) = c(2,1) - coeff*c(1,1)
      c(2,2) = c(2,2) - coeff*c(1,2)
      c(2,3) = c(2,3) - coeff*c(1,3)
      c(2,4) = c(2,4) - coeff*c(1,4)
      c(2,5) = c(2,5) - coeff*c(1,5)
      r(2)   = r(2)   - coeff*r(1)

      coeff = lhs(3,1)
      lhs(3,2)= lhs(3,2) - coeff*lhs(1,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(1,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(1,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(1,5)
      c(3,1) = c(3,1) - coeff*c(1,1)
      c(3,2) = c(3,2) - coeff*c(1,2)
      c(3,3) = c(3,3) - coeff*c(1,3)
      c(3,4) = c(3,4) - coeff*c(1,4)
      c(3,5) = c(3,5) - coeff*c(1,5)
      r(3)   = r(3)   - coeff*r(1)

      coeff = lhs(4,1)
      lhs(4,2)= lhs(4,2) - coeff*lhs(1,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(1,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(1,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(1,5)
      c(4,1) = c(4,1) - coeff*c(1,1)
      c(4,2) = c(4,2) - coeff*c(1,2)
      c(4,3) = c(4,3) - coeff*c(1,3)
      c(4,4) = c(4,4) - coeff*c(1,4)
      c(4,5) = c(4,5) - coeff*c(1,5)
      r(4)   = r(4)   - coeff*r(1)

      coeff = lhs(5,1)
      lhs(5,2)= lhs(5,2) - coeff*lhs(1,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(1,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(1,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(1,5)
      c(5,1) = c(5,1) - coeff*c(1,1)
      c(5,2) = c(5,2) - coeff*c(1,2)
      c(5,3) = c(5,3) - coeff*c(1,3)
      c(5,4) = c(5,4) - coeff*c(1,4)
      c(5,5) = c(5,5) - coeff*c(1,5)
      r(5)   = r(5)   - coeff*r(1)

      pivot = 1.00d0/lhs(2,2)
      lhs(2,3) = lhs(2,3)*pivot
      lhs(2,4) = lhs(2,4)*pivot
      lhs(2,5) = lhs(2,5)*pivot
      c(2,1) = c(2,1)*pivot
      c(2,2) = c(2,2)*pivot
      c(2,3) = c(2,3)*pivot
      c(2,4) = c(2,4)*pivot
      c(2,5) = c(2,5)*pivot
      r(2)   = r(2)  *pivot

      coeff = lhs(1,2)
      lhs(1,3)= lhs(1,3) - coeff*lhs(2,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(2,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(2,5)
      c(1,1) = c(1,1) - coeff*c(2,1)
      c(1,2) = c(1,2) - coeff*c(2,2)
      c(1,3) = c(1,3) - coeff*c(2,3)
      c(1,4) = c(1,4) - coeff*c(2,4)
      c(1,5) = c(1,5) - coeff*c(2,5)
      r(1)   = r(1)   - coeff*r(2)

      coeff = lhs(3,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(2,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(2,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(2,5)
      c(3,1) = c(3,1) - coeff*c(2,1)
      c(3,2) = c(3,2) - coeff*c(2,2)
      c(3,3) = c(3,3) - coeff*c(2,3)
      c(3,4) = c(3,4) - coeff*c(2,4)
      c(3,5) = c(3,5) - coeff*c(2,5)
      r(3)   = r(3)   - coeff*r(2)

      coeff = lhs(4,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(2,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(2,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(2,5)
      c(4,1) = c(4,1) - coeff*c(2,1)
      c(4,2) = c(4,2) - coeff*c(2,2)
      c(4,3) = c(4,3) - coeff*c(2,3)
      c(4,4) = c(4,4) - coeff*c(2,4)
      c(4,5) = c(4,5) - coeff*c(2,5)
      r(4)   = r(4)   - coeff*r(2)

      coeff = lhs(5,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(2,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(2,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(2,5)
      c(5,1) = c(5,1) - coeff*c(2,1)
      c(5,2) = c(5,2) - coeff*c(2,2)
      c(5,3) = c(5,3) - coeff*c(2,3)
      c(5,4) = c(5,4) - coeff*c(2,4)
      c(5,5) = c(5,5) - coeff*c(2,5)
      r(5)   = r(5)   - coeff*r(2)

      pivot = 1.00d0/lhs(3,3)
      lhs(3,4) = lhs(3,4)*pivot
      lhs(3,5) = lhs(3,5)*pivot
      c(3,1) = c(3,1)*pivot
      c(3,2) = c(3,2)*pivot
      c(3,3) = c(3,3)*pivot
      c(3,4) = c(3,4)*pivot
      c(3,5) = c(3,5)*pivot
      r(3)   = r(3)  *pivot

      coeff = lhs(1,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(3,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(3,5)
      c(1,1) = c(1,1) - coeff*c(3,1)
      c(1,2) = c(1,2) - coeff*c(3,2)
      c(1,3) = c(1,3) - coeff*c(3,3)
      c(1,4) = c(1,4) - coeff*c(3,4)
      c(1,5) = c(1,5) - coeff*c(3,5)
      r(1)   = r(1)   - coeff*r(3)

      coeff = lhs(2,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(3,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(3,5)
      c(2,1) = c(2,1) - coeff*c(3,1)
      c(2,2) = c(2,2) - coeff*c(3,2)
      c(2,3) = c(2,3) - coeff*c(3,3)
      c(2,4) = c(2,4) - coeff*c(3,4)
      c(2,5) = c(2,5) - coeff*c(3,5)
      r(2)   = r(2)   - coeff*r(3)

      coeff = lhs(4,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(3,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(3,5)
      c(4,1) = c(4,1) - coeff*c(3,1)
      c(4,2) = c(4,2) - coeff*c(3,2)
      c(4,3) = c(4,3) - coeff*c(3,3)
      c(4,4) = c(4,4) - coeff*c(3,4)
      c(4,5) = c(4,5) - coeff*c(3,5)
      r(4)   = r(4)   - coeff*r(3)

      coeff = lhs(5,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(3,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(3,5)
      c(5,1) = c(5,1) - coeff*c(3,1)
      c(5,2) = c(5,2) - coeff*c(3,2)
      c(5,3) = c(5,3) - coeff*c(3,3)
      c(5,4) = c(5,4) - coeff*c(3,4)
      c(5,5) = c(5,5) - coeff*c(3,5)
      r(5)   = r(5)   - coeff*r(3)

      pivot = 1.00d0/lhs(4,4)
      lhs(4,5) = lhs(4,5)*pivot
      c(4,1) = c(4,1)*pivot
      c(4,2) = c(4,2)*pivot
      c(4,3) = c(4,3)*pivot
      c(4,4) = c(4,4)*pivot
      c(4,5) = c(4,5)*pivot
      r(4)   = r(4)  *pivot

      coeff = lhs(1,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(4,5)
      c(1,1) = c(1,1) - coeff*c(4,1)
      c(1,2) = c(1,2) - coeff*c(4,2)
      c(1,3) = c(1,3) - coeff*c(4,3)
      c(1,4) = c(1,4) - coeff*c(4,4)
      c(1,5) = c(1,5) - coeff*c(4,5)
      r(1)   = r(1)   - coeff*r(4)

      coeff = lhs(2,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(4,5)
      c(2,1) = c(2,1) - coeff*c(4,1)
      c(2,2) = c(2,2) - coeff*c(4,2)
      c(2,3) = c(2,3) - coeff*c(4,3)
      c(2,4) = c(2,4) - coeff*c(4,4)
      c(2,5) = c(2,5) - coeff*c(4,5)
      r(2)   = r(2)   - coeff*r(4)

      coeff = lhs(3,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(4,5)
      c(3,1) = c(3,1) - coeff*c(4,1)
      c(3,2) = c(3,2) - coeff*c(4,2)
      c(3,3) = c(3,3) - coeff*c(4,3)
      c(3,4) = c(3,4) - coeff*c(4,4)
      c(3,5) = c(3,5) - coeff*c(4,5)
      r(3)   = r(3)   - coeff*r(4)

      coeff = lhs(5,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(4,5)
      c(5,1) = c(5,1) - coeff*c(4,1)
      c(5,2) = c(5,2) - coeff*c(4,2)
      c(5,3) = c(5,3) - coeff*c(4,3)
      c(5,4) = c(5,4) - coeff*c(4,4)
      c(5,5) = c(5,5) - coeff*c(4,5)
      r(5)   = r(5)   - coeff*r(4)

      pivot = 1.00d0/lhs(5,5)
      c(5,1) = c(5,1)*pivot
      c(5,2) = c(5,2)*pivot
      c(5,3) = c(5,3)*pivot
      c(5,4) = c(5,4)*pivot
      c(5,5) = c(5,5)*pivot
      r(5)   = r(5)  *pivot

      coeff = lhs(1,5)
      c(1,1) = c(1,1) - coeff*c(5,1)
      c(1,2) = c(1,2) - coeff*c(5,2)
      c(1,3) = c(1,3) - coeff*c(5,3)
      c(1,4) = c(1,4) - coeff*c(5,4)
      c(1,5) = c(1,5) - coeff*c(5,5)
      r(1)   = r(1)   - coeff*r(5)

      coeff = lhs(2,5)
      c(2,1) = c(2,1) - coeff*c(5,1)
      c(2,2) = c(2,2) - coeff*c(5,2)
      c(2,3) = c(2,3) - coeff*c(5,3)
      c(2,4) = c(2,4) - coeff*c(5,4)
      c(2,5) = c(2,5) - coeff*c(5,5)
      r(2)   = r(2)   - coeff*r(5)

      coeff = lhs(3,5)
      c(3,1) = c(3,1) - coeff*c(5,1)
      c(3,2) = c(3,2) - coeff*c(5,2)
      c(3,3) = c(3,3) - coeff*c(5,3)
      c(3,4) = c(3,4) - coeff*c(5,4)
      c(3,5) = c(3,5) - coeff*c(5,5)
      r(3)   = r(3)   - coeff*r(5)

      coeff = lhs(4,5)
      c(4,1) = c(4,1) - coeff*c(5,1)
      c(4,2) = c(4,2) - coeff*c(5,2)
      c(4,3) = c(4,3) - coeff*c(5,3)
      c(4,4) = c(4,4) - coeff*c(5,4)
      c(4,5) = c(4,5) - coeff*c(5,5)
      r(4)   = r(4)   - coeff*r(5)

      return
      end

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

      subroutine binvrhs( lhs,r )

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

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

      implicit none

      double precision pivot, coeff, lhs
      dimension lhs(5,5)
      double precision r(5)

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

      pivot = 1.00d0/lhs(1,1)
      lhs(1,2) = lhs(1,2)*pivot
      lhs(1,3) = lhs(1,3)*pivot
      lhs(1,4) = lhs(1,4)*pivot
      lhs(1,5) = lhs(1,5)*pivot
      r(1)   = r(1)  *pivot

      coeff = lhs(2,1)
      lhs(2,2)= lhs(2,2) - coeff*lhs(1,2)
      lhs(2,3)= lhs(2,3) - coeff*lhs(1,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(1,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(1,5)
      r(2)   = r(2)   - coeff*r(1)

      coeff = lhs(3,1)
      lhs(3,2)= lhs(3,2) - coeff*lhs(1,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(1,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(1,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(1,5)
      r(3)   = r(3)   - coeff*r(1)

      coeff = lhs(4,1)
      lhs(4,2)= lhs(4,2) - coeff*lhs(1,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(1,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(1,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(1,5)
      r(4)   = r(4)   - coeff*r(1)

      coeff = lhs(5,1)
      lhs(5,2)= lhs(5,2) - coeff*lhs(1,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(1,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(1,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(1,5)
      r(5)   = r(5)   - coeff*r(1)

      pivot = 1.00d0/lhs(2,2)
      lhs(2,3) = lhs(2,3)*pivot
      lhs(2,4) = lhs(2,4)*pivot
      lhs(2,5) = lhs(2,5)*pivot
      r(2)   = r(2)  *pivot

      coeff = lhs(1,2)
      lhs(1,3)= lhs(1,3) - coeff*lhs(2,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(2,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(2,5)
      r(1)   = r(1)   - coeff*r(2)

      coeff = lhs(3,2)
      lhs(3,3)= lhs(3,3) - coeff*lhs(2,3)
      lhs(3,4)= lhs(3,4) - coeff*lhs(2,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(2,5)
      r(3)   = r(3)   - coeff*r(2)

      coeff = lhs(4,2)
      lhs(4,3)= lhs(4,3) - coeff*lhs(2,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(2,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(2,5)
      r(4)   = r(4)   - coeff*r(2)

      coeff = lhs(5,2)
      lhs(5,3)= lhs(5,3) - coeff*lhs(2,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(2,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(2,5)
      r(5)   = r(5)   - coeff*r(2)

      pivot = 1.00d0/lhs(3,3)
      lhs(3,4) = lhs(3,4)*pivot
      lhs(3,5) = lhs(3,5)*pivot
      r(3)   = r(3)  *pivot

      coeff = lhs(1,3)
      lhs(1,4)= lhs(1,4) - coeff*lhs(3,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(3,5)
      r(1)   = r(1)   - coeff*r(3)

      coeff = lhs(2,3)
      lhs(2,4)= lhs(2,4) - coeff*lhs(3,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(3,5)
      r(2)   = r(2)   - coeff*r(3)

      coeff = lhs(4,3)
      lhs(4,4)= lhs(4,4) - coeff*lhs(3,4)
      lhs(4,5)= lhs(4,5) - coeff*lhs(3,5)
      r(4)   = r(4)   - coeff*r(3)

      coeff = lhs(5,3)
      lhs(5,4)= lhs(5,4) - coeff*lhs(3,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(3,5)
      r(5)   = r(5)   - coeff*r(3)

      pivot = 1.00d0/lhs(4,4)
      lhs(4,5) = lhs(4,5)*pivot
      r(4)   = r(4)  *pivot

      coeff = lhs(1,4)
      lhs(1,5)= lhs(1,5) - coeff*lhs(4,5)
      r(1)   = r(1)   - coeff*r(4)

      coeff = lhs(2,4)
      lhs(2,5)= lhs(2,5) - coeff*lhs(4,5)
      r(2)   = r(2)   - coeff*r(4)

      coeff = lhs(3,4)
      lhs(3,5)= lhs(3,5) - coeff*lhs(4,5)
      r(3)   = r(3)   - coeff*r(4)

      coeff = lhs(5,4)
      lhs(5,5)= lhs(5,5) - coeff*lhs(4,5)
      r(5)   = r(5)   - coeff*r(4)

      pivot = 1.00d0/lhs(5,5)
      r(5)   = r(5)  *pivot

      coeff = lhs(1,5)
      r(1)   = r(1)   - coeff*r(5)

      coeff = lhs(2,5)
      r(2)   = r(2)   - coeff*r(5)

      coeff = lhs(3,5)
      r(3)   = r(3)   - coeff*r(5)

      coeff = lhs(4,5)
      r(4)   = r(4)   - coeff*r(5)

      return
      end


! { dg-do compile }
! { dg-options "-floop-nest-optimize -O2 -ffast-math" }
! PR67518 :  isl: position out of bounds
MODULE ao_util
    INTEGER, PARAMETER :: dp=8
CONTAINS
  FUNCTION exp_radius(l,alpha,threshold,prefactor,epsin) RESULT(radius)
    REAL(KIND=dp), INTENT(IN)                :: alpha, threshold, prefactor
    REAL(KIND=dp), INTENT(IN), OPTIONAL      :: epsin
    DO
       IF (iter.gt.maxiter) THEN
          CALL stop_program(routineN,moduleN,1,"exceeded")
       ENDIF
    ENDDO
    CALL stop_program(routineN,moduleN,1,"exceeded")
  END FUNCTION exp_radius
 FUNCTION exp_radius_very_extended(la_min,la_max,lb_min,lb_max,pab,o1,o2,ra,rb,rp,&
                          zetp,eps,prefactor,cutoff,epsin) RESULT(radius)
    REAL(KIND=dp), DIMENSION(:, :), &
      OPTIONAL, POINTER                      :: pab
    REAL(KIND=dp), INTENT(IN)                :: ra(3), rb(3), rp(3), zetp, &
                                                eps, prefactor, cutoff
    REAL(KIND=dp)                            :: bini, binj, coef(0:20), &
                                                epsin_local, polycoef(0:60), &
                                                rad_b, s1, s2
    IF (PRESENT(pab)) THEN
    ENDIF
    DO lxa=0,la_max
    DO lxb=0,lb_max
       coef(0:la_max+lb_max)=0.0_dp
       DO i=0,lxa
          DO j=0,lxb
             coef(lxa+lxb-i-j)=coef(lxa+lxb-i-j) + bini*binj*s1*s2
          ENDDO
       ENDDO
       DO i=0,lxa+lxb
          polycoef(i)=MAX(polycoef(i),coef(i))
       ENDDO
    ENDDO
    ENDDO
    DO i=0,la_max+lb_max
          radius=MAX(radius,exp_radius(i,zetp,eps,polycoef(i),epsin_local) )
    ENDDO
  END FUNCTION exp_radius_very_extended
END MODULE ao_util


          program demo_accdig ! fortran 90 example
          use M_verify, only : accdig
          implicit none
          integer :: digi
          integer :: i10, i20, i30
          integer :: ind, ind1, ind2
          real    :: acurcy, acurcy1, acurcy2
          real    :: a, b
          real    :: vals(9)
          data vals/ &
            &1.234680,   1.2345378,  2.2234568, 1.2345678, &
            &1.2345679, -1.2345678, 76.234567,  2.4691356, &
            &0.0/
             write(*,*)'========================='
             do i10=0,16
                a=1.0
                b=a+1.0/(10**i10)
                call accdig(a,b,8.0,acurcy,ind)
                write(*,*)i10,a,b,acurcy,ind
             enddo
             write(*,*)'========================='
             digi=16
             do i20=0,digi
                a=1.0
                b=a+1.0/(10**i20)
                call accdig(a,b,real(digi),acurcy,ind)
                write(*,*)i20,a,b,acurcy,ind
             enddo
             write(*,*)'========================='
             do i30=1,9
                call accdig(1.2345678,vals(i30),8.0,acurcy1,ind1)
                call accdig(vals(i30),1.2345678,8.0,acurcy2,ind2)
                write(*,*)i30,vals(i30),acurcy1,acurcy2,ind1,ind2
             enddo
          end program demo_accdig


program test
      real :: a, b, c
      a = 10.33542
      b = 10.4535

      c = max(a, b)

      print *, c
end program test


      DOUBLE PRECISION FUNCTION MB03MY( NX, X, INCX )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the absolute minimal value of NX elements in an array.
C     The function returns the value zero if NX < 1.
C
C     ARGUMENTS
C
C     NX      (input) INTEGER
C             The number of elements in X to be examined.
C
C     X       (input) DOUBLE PRECISION array, dimension (NX * INCX)
C             The one-dimensional array of which the absolute minimal
C             value of the elements is to be computed.
C             This array is not referenced if NX < 1.
C
C     INCX    (input) INTEGER
C             The increment to be taken in the array X, defining the
C             distance between two consecutive elements.  INCX >= 1.
C             INCX = 1, if all elements are contiguous in memory.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MB03AZ by S. Van Huffel, Katholieke
C     University, Leuven, Belgium.
C
C     REVISIONS
C
C     June 16, 1997.
C
C     KEYWORDS
C
C     None.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INCX, NX
C     .. Array Arguments ..
      DOUBLE PRECISION  X(*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  DX
C     .. Intrinsic Functions ..
      INTRINSIC         ABS
C     .. Executable Statements ..
C
C     Quick return if possible.
C
      IF ( NX.LE.0 ) THEN
         MB03MY = ZERO
         RETURN
      END IF
C
      MB03MY = ABS( X(1) )
C
      DO 20 I = 1+INCX, NX*INCX, INCX
         DX = ABS( X(I) )
         IF ( DX.LT.MB03MY ) MB03MY = DX
   20 CONTINUE
C
      RETURN
C *** Last line of MB03MY ***
      END


!
! This program does a correctness check for
! ... = ARRAY[idx] and ... = SCALAR[idx]
!
program main
  implicit none
  integer, parameter :: n = 3
  integer, parameter :: m = 4

  logical :: error_printed=.false.

  ! Allocatable coarrays
  call one(-5, 1)
  call one(0, 0)
  call one(1, -5)
  call one(0, -11)

  ! Static coarrays
  call two()
  call three()

  if (error_printed)  error stop
  sync all

  if (this_image()==1) print *,'Test passed.'
contains
  subroutine one(lb1, lb2)
    integer, value :: lb1, lb2

    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
    integer, allocatable :: caf(:,:)[:]
    integer, allocatable :: a(:,:), b(:,:), c(:,:)

    allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
         a(lb1:n+lb1-1, lb2:m+lb2-1), &
         b(lb1:n+lb1-1, lb2:m+lb2-1), &
         c(lb1:n+lb1-1, lb2:m+lb2-1))

    b = reshape([(i*33, i = 1, size(b))], shape(b))

    ! Whole array: ARRAY = SCALAR
    a = b
    caf = -42
    c = caf
    sync all
    if(this_image() == 1) then
       a(:,:) = caf(lb1,lb2)[num_images()]
    end if
    sync all
    if(this_image()==1) then
       if(any (a /= c)) call print_and_register( "ARRAY = SCALAR failed in get_array_test")
    endif

    ! Whole array: ARRAY = ARRAY
    caf = -42
    a = b
    c = caf
    if (this_image() == 1) then
       a(:,:) = caf(:,:)[num_images()]
    endif
    sync all
    if(this_image()==1) then
       if (any (a /= c)) then
          print *, 'RES 1:', any (a /= c)
          print *, a
          print *, c
          ! FIXME: Without the print lines above, it always fails. Why?
          call print_and_register( "ARRAY = ARRAY failed in get_array_test")
       end if
    endif

    ! Scalar assignment
    a = -42
    caf = -42
    c = caf
    sync all
    do j = lb2, m+lb2-1
       do i = n+lb1-1, lb1, -2
          a(i,j) = b(i,j)
       end do
    end do
    do j = lb2, m+lb2-1
       do i = lb1, n+lb1-1, 2
          a(i,j) = b(i,j)
       end do
    end do
    sync all
    if(this_image() == 1) then
       do j = lb2, m+lb2-1
          do i = n+lb1-1, lb1, -2
             a(i,j) = caf(i,j)[num_images()]
          end do
       end do
       do j = lb2, m+lb2-1
          do i = lb1, n+lb1-1, 2
             a(i,j) = caf(i,j)[num_images()]
          end do
       end do
    endif
    sync all
    if(this_image() == 1) then
       if (any (a /= c)) then
          print *, 'RES 2:', any (a /= c)
          print *, this_image(), ': ', a
          print *, this_image(), ': ', c
          ! FIXME: Without the print lines above, it always fails. Why?
          call print_and_register( "scalar assignment failed in get_array_test")
       end if
    endif
    ! Array sections with different ranges and pos/neg strides
    do i_sgn1 = -1, 1, 2
       do i_sgn2 = -1, 1, 2
          do i=lb1, n+lb1-1
             do i_e=lb1, n+lb1-1
                do i_s=1, n
                   do j=lb2, m+lb2-1
                      do j_e=lb2, m+lb2-1
                         do j_s=1, m
                            ! ARRAY = SCALAR
                            a = -42
                            caf = -42
                            c = a
                            a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
                            sync all
                            if (this_image() == 1) then
                               a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = caf(lb1,lb2)[num_images()]
                            end if
                            sync all
                            if (this_image() == 1) then
                               if (any (a /= c)) then
                                  print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
                                       lb2,":",m+lb2-1
                                  print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
                                       ", ", j,":",j_e,":",j_s*i_sgn2
                                  print *, i
                                  print *, a
                                  print *, c
                                  print *, a-c
                                  call print_and_register( "array sections with ranges and strides failed in get_array_test")
                               endif
                            end if
                            ! ARRAY = ARRAY
                            caf = -42
                            a = -42
                            c = a
                            a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
                                 = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                            sync all
                            if (this_image() == 1) then
                               a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
                            end if
                            sync all

                            if (this_image() == 1) then
                               if (any (a /= c)) then
                                  print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
                                       lb2,":",m+lb2-1
                                  print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
                                       ", ", j,":",j_e,":",j_s*i_sgn2
                                  print *, i
                                  print *, a
                                  print *, c
                                  print *, a-c
                                  call print_and_register( "array sections with ranges and strides failed in get_array_test")
                               endif
                            end if
                         end do
                      end do
                   end do
                end do
             end do
          end do
       end do
    end do
  end subroutine one

  subroutine two()
    integer, parameter :: lb1 = -5, lb2 = 1

    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
    integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
    integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
    integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)

    b = reshape([(i*33, i = 1, size(b))], shape(b))

    ! Whole array: ARRAY = SCALAR
    caf = -42
    a = -42
    a(:,:) = b(lb1, lb2)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(lb1, lb2)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           call print_and_register( "Array = scalar failed in subroutine two get_array_test")
    end if

    ! Whole array: ARRAY = ARRAY
    caf = -42
    a = -42
    a(:,:) = b(:, :)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(:, :)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           call print_and_register( "Array = array failed in subroutine two get_array_test")
    end if

    ! Scalar assignment
    caf = -42
    a = -42
    do j = lb2, m+lb2-1
      do i = n+lb1-1, 1, -2
        a(i,j) = b(i,j)
      end do
    end do
    do j = lb2, m+lb2-1
      do i = 1, n+lb1-1, 2
        a(i,j) = b(i,j)
      end do
    end do
    sync all
    if (this_image() == 1) then
      do j = lb2, m+lb2-1
        do i = n+lb1-1, 1, -2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
      do j = lb2, m+lb2-1
        do i = 1, n+lb1-1, 2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           call print_and_register( "scalar assignment failed in subroutine two get_array_test")
    end if

    ! Array sections with different ranges and pos/neg strides
    do i_sgn1 = -1, 1, 2
      do i_sgn2 = -1, 1, 2
        do i=lb1, n+lb1-1
          do i_e=lb1, n+lb1-1
            do i_s=1, n
              do j=lb2, m+lb2-1
                do j_e=lb2, m+lb2-1
                  do j_s=1, m
                    ! ARRAY = SCALAR
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(lb1, lb2)
                    end if
                    sync all

                    ! ARRAY = ARRAY
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
                         = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    end if
                    sync all

                    if (this_image() == num_images()) then
                      if (any (a /= caf)) then
                        print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
                             lb2,":",m+lb2-1
                        print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
                             ", ", j,":",j_e,":",j_s*i_sgn2
                        print *, i
                        print *, a
                        print *, caf
                        print *, a-caf
                        call print_and_register( "arrays with ranges and strides failed sub. two get_array_test failed")
                      endif
                    end if
                  end do
                end do
              end do
            end do
          end do
        end do
      end do
    end do
  end subroutine two

  subroutine three()
    integer, parameter :: lb1 = 0, lb2 = 0

    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
    integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
    integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
    integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)

    b = reshape([(i*33, i = 1, size(b))], shape(b))

    ! Whole array: ARRAY = SCALAR
    caf = -42
    a = -42
    a(:,:) = b(lb1, lb2)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(lb1, lb2)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           call print_and_register( "Array = scalar subroutine three get_array_test failed")
    end if

    ! Whole array: ARRAY = ARRAY
    caf = -42
    a = -42
    a(:,:) = b(:, :)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(:, :)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           call print_and_register( "Array = array subroutine three get_array_test failed")
    end if

    ! Scalar assignment
    caf = -42
    a = -42
    do j = lb2, m+lb2-1
      do i = n+lb1-1, 1, -2
        a(i,j) = b(i,j)
      end do
    end do
    do j = lb2, m+lb2-1
      do i = 1, n+lb1-1, 2
        a(i,j) = b(i,j)
      end do
    end do
    sync all
    if (this_image() == 1) then
      do j = lb2, m+lb2-1
        do i = n+lb1-1, 1, -2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
      do j = lb2, m+lb2-1
        do i = 1, n+lb1-1, 2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           call print_and_register( "scalar assignment subroutine three get_array_test failed")
    end if

    ! Array sections with different ranges and pos/neg strides
    do i_sgn1 = -1, 1, 2
      do i_sgn2 = -1, 1, 2
        do i=lb1, n+lb1-1
          do i_e=lb1, n+lb1-1
            do i_s=1, n
              do j=lb2, m+lb2-1
                do j_e=lb2, m+lb2-1
                  do j_s=1, m
                    ! ARRAY = SCALAR
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(lb1, lb2)
                    end if
                    sync all

                    ! ARRAY = ARRAY
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
                         = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    end if
                    sync all

                    if (this_image() == num_images()) then
                      if (any (a /= caf)) then
                        print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
                             lb2,":",m+lb2-1
                        print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
                             ", ", j,":",j_e,":",j_s*i_sgn2
                        print *, i
                        print *, a
                        print *, caf
                        print *, a-caf
                        call print_and_register( "range stride in subroutine three get_array_test failed")
                      endif
                    end if
                  end do
                end do
              end do
            end do
          end do
        end do
      end do
    end do
  end subroutine three

  subroutine print_and_register(error_message)
    use iso_fortran_env, only : error_unit
    character(len=*), intent(in) :: error_message
    write(error_unit,*) error_message
    error_printed=.true.
  end subroutine

end program main


! Copyright (c) 2005-2010, 2012-2013, Andrew Hang Chen and contributors,
! All rights reserved.
! Licensed under the 3-clause BSD license.

module calculator
  implicit none
contains
  subroutine add (a, b, output)
    integer, intent (in) :: a, b
    integer, intent (out) :: output

    output = a + b
  end subroutine add
end module calculator


program hash_table_test

   use hash_table_module

   !==========================================================
   integer, parameter :: slen = 10
   integer            :: i, j, k, flag, val, strn(slen), ierror, &
                         base, r, a, b, n
   real               :: t1, t2, lf
   integer, dimension(27) :: asciis
   integer, dimension(:), allocatable :: keys_i, vals_i
   character(slen), dimension(:), allocatable :: keys_s
   character(slen) :: str
   character(6)         :: name

   type(ht_int) :: htable_int
   type(ht_str) :: htable_str
   !==========================================================

   lf = 0.70 ! Load factor

   !==========================================================

   write(*,"(/,'Integer Functionality Test'/,26('='))")
   n = 1000
   allocate(keys_i(n),vals_i(n),STAT=ierror)
   if(ierror /= 0) write(*,*) "Memory allocation error: keys, vals"

   ! Set up key/val pairs
   do i = 1,n
      keys_i(i) = n-i+1 ! keys are reversed order
      vals_i(i) = i
   end do

   do k = 1,7
      select case(k)
      case(1); name = 'djb2  '
      case(2); name = 'djb2a '
      case(3); name = 'sdbm  '
      case(4); name = 'fnv1  '
      case(5); name = 'fnv1a '
      case(6); name = 'mmh2  '
      case(7); name = 'mmh3  '
      end select

      write(*,*) "Testing algorithm: ",name

      call htable_int%init(n,flag,alg=name,load_factor=lf)
      if(flag /= 0) write(*,*) "Error in init: ",name
      ! If odd numbered, use 'simple' key/val removal scheme instead of 'shift'
      if(mod(k,2) == 1) htable_int%remove => trem_simple_int

      ! Set key/val pairs
      do i = 1,n
         call htable_int%insert(keys_i(i),vals_i(i),flag)
         if(flag /= 0) write(*,*) "Error in set1: ",name
      end do
      ! Get key/val pairs
      do i = 1,n
         call htable_int%get(keys_i(i),val,flag)
         if(flag /= 0 .or. val /= vals_i(i)) write(*,*) "Error in get1: ",name, i, keys_i(i)
      end do
      ! Remove first quarter of keys
      do i = 1,n/4
         call htable_int%remove(keys_i(i),flag)
         if(flag /= 0) write(*,*) "Error in remove: ",name
      end do
      ! Add new set of key/val pairs with negated keys
      do i = 1,n/4
         call htable_int%insert(-keys_i(i),vals_i(i),flag)
         if(flag /= 0) write(*,*) "Error in set2: ",name
      end do
      ! Test get
      do i = 1,n/4
         call htable_int%get(-keys_i(i),val,flag)
         if(flag /= 0 .or. val /= vals_i(i)) write(*,*) "Error in get2: ",name
      end do
      ! Test overwriting (flag will be == 1)
      do i = 1,n/4
         call htable_int%set(-keys_i(i),-vals_i(i),flag)
         if(flag /= 0) write(*,*) "Error in set3: ",name
      end do
      do i = 1,n/4
         call htable_int%get(-keys_i(i),val,flag)
         if(flag /= 0 .or. val /= -vals_i(i)) write(*,*) "Error in get3: ",name
      end do
      call htable_int%destruct(flag)
      if(flag /= 0) write(*,*) "Error in destruct: ",name
   end do
   deallocate(keys_i,vals_i)

   !==========================================================

   n = 10000000

   write(*,"(/,'Integer Speed Test: ',i8,' 8-byte integers'/,44('='))") n

   call htable_int%init(n,flag,alg='mmh2 ',load_factor=lf)

   call cpu_time(t1)
   do i = 1,n
      call htable_int%insert(i,i,flag)
   end do
   call cpu_time(t2)
   write(*,"(' HT Insert: ',f5.2,'s')") t2-t1

   call cpu_time(t1)
   call htable_int%resize(int(n/lf),flag)
   call cpu_time(t2)
   write(*,"(' HT Resize: ',f5.2,'s')") t2-t1

   call cpu_time(t1)
   do i = 1,n
      call htable_int%get(i,val,flag)
      if(i /= val) write(*,"('Val not found: ',i8,i8)") i, val
   end do
   call cpu_time(t2)
   write(*,"(' HT Get:    ',f5.2,'s')") t2-t1

   call htable_int%destruct(flag)

   !==========================================================

   write(*,"(//,'String Functionality Test'/,25('='))")
   n = 1000

   ! Use base conversion to make n strings which utilize character indices
   ! 1 through 'base' from among ASCII 32 & 97-122 (space + lower case letters)
   ! e.g. base 5 would use space + a,b,c,d to make strings '   ' through 'ddd'
   allocate(keys_s(n),vals_i(n),STAT=ierror)
   if(ierror /= 0) write(*,"('Mem alloc error')")

   asciis(1) = 32
   asciis(2:27) = [(i,i=97,122)]

   base = 7

   do i = 1,n
      b = i
      do j = 1,slen                ! Do j=1,slen Euclidean divisions
         a = b/base                ! integer division, get seed for next digit
         strn(j)  = b - a*base +1  ! Fortran is indexed to 1, modulo is indexed to 0
         b = a                     ! set b = a to start on next digit
      end do

      do j = 1,slen        ! Convert from index to ASCII code to character
         str(j:j) = achar(asciis(strn(j)))
      end do
      keys_s(i) = str
      vals_i(i) = i
   end do

   do k = 1,7
      select case(k)
      case(1); name = 'djb2  '
      case(2); name = 'djb2a '
      case(3); name = 'sdbm  '
      case(4); name = 'fnv1  '
      case(5); name = 'fnv1a '
      case(6); name = 'mmh2  '
      case(7); name = 'mmh3  '
      end select

      write(*,*) "Testing algorithm: ",name

      call htable_str%init(n,flag,alg=name,load_factor=lf)
      if(flag /= 0) write(*,*) "Error in init: ",name
      ! If odd numbered, use 'simple' key/val removal scheme instead of 'shift'
      if(mod(k,2) == 1) htable_str%remove => trem_simple_str

      ! Set key/val pairs
      do i = 1,n
         call htable_str%insert(keys_s(i),vals_i(i),flag)
         if(flag /= 0) write(*,*) "Error in insert: ",name
      end do
      ! Get key/val pairs
      do i = 1,n
         call htable_str%get(keys_s(i),val,flag)
         if(flag /= 0 .or. val /= vals_i(i)) write(*,*) "Error in get1: ",name
      end do
      ! Remove first quarter of keys
      do i = 1,n/4
         call htable_str%remove(keys_s(i),flag)
         if(flag /= 0) write(*,*) "Error in remove: ",name
      end do
      ! Get key/val pairs
      do i = (n/4+1),n
         call htable_str%get(keys_s(i),val,flag)
         if(flag /= 0 .or. val /= vals_i(i)) write(*,*) "Error in get2: ",name
      end do
      ! Test overwriting (flag will be == 1)
      do i = (n/4+1),n/2
         call htable_str%set(keys_s(i),-vals_i(i),flag)
         if(flag /= 0) write(*,*) "Error in set: ",name, flag, vals_i(i),keys_s(i)
      end do
      do i = (n/4+1),n/2
         call htable_str%get(keys_s(i),val,flag)
         if(flag /= 0 .or. val /= -vals_i(i)) write(*,*) "Error in get3: ",name
      end do
      call htable_str%destruct(flag)
      if(flag /= 0) write(*,*) "Error in destruct: ",name
   end do
   deallocate(keys_s,vals_i)

   !==========================================================

   n = 1000000

   allocate(keys_s(n),STAT=ierror)
   if(ierror /= 0) write(*,"('Mem alloc error')")

   asciis(1) = 32
   asciis(2:27) = [(i,i=97,122)]

   base = 5

   do i = 1,n
      b = i
      do j = 1,slen        ! Do j=1,slen Euclidean divisions
         a = b/base        ! integer division, get seed for next digit
         r = b - a*base    ! get remainder for current digit
         b = a             ! set b = a to start on next digit
         strn(j) = r + 1   ! Fortran is indexed to 1, modulo is indexed to 0
      end do

      do j = 1,slen        ! Convert from index to ASCII code to character
         str(j:j) = achar(asciis(strn(j)))
      end do
      keys_s(i) = str
   end do

   write(*,"(/,'String Speed Test: ',i8,' ',i2,'-byte strings'/,43('='))") n,slen

   call htable_str%init(n,flag,alg='mmh2 ',load_factor=lf)

   call cpu_time(t1)
   do i = 1,n
      call htable_str%insert(keys_s(i),i,flag)
      if(flag /= 0) write(*,*) 'Error writing key: ', keys_s(i)
   end do
   call cpu_time(t2)
   write(*,"(' HT Insert: ',f5.2,'s')") t2-t1

   call cpu_time(t1)
   call htable_str%resize(int(n/lf),flag)
   call cpu_time(t2)
   write(*,"(' HT Resize: ',f5.2,'s')") t2-t1

   call cpu_time(t1)
   do i = 1,n
      call htable_str%get(keys_s(i),val,flag)
      if(i /= val) write(*,*) 'Error getting val: ', i, val
   end do
   call cpu_time(t2)
   write(*,"(' HT Get:    ',f5.2,'s')") t2-t1

   call htable_str%destruct(flag)

   write(*,"(//,'Done...')")
   read(*,"(a)") str

end program


MODULE mod_prec

  ! Note: This intrinsic module is provided starting in Fortran 2003
  USE ISO_FORTRAN_ENV, ONLY: CHARACTER_STORAGE_SIZE

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: dl, dd, dc, dz, sz_l, sz_d, sz_c, sz_z

  INTRINSIC :: STORAGE_SIZE

  ! Precision constants
  INTEGER, PARAMETER :: dl = SELECTED_INT_KIND(18)      ! 64-bit (long)
  INTEGER, PARAMETER :: dd = SELECTED_REAL_KIND(14,100) ! 64-bit (double)
  INTEGER, PARAMETER :: dc = KIND( (0.0, 1.0) )
  INTEGER, PARAMETER :: dz = KIND( (0.0_dd, 1.0_dd) )

  ! Dummy variables for STORAGE_SIZE()
  INTEGER(KIND=dl) :: l
  REAL(KIND=dd)    :: d
  COMPLEX(KIND=dc) :: c
  COMPLEX(KIND=dz) :: z

  ! Sizes in bytes
  INTEGER(KIND=dl), PARAMETER :: sz_l = STORAGE_SIZE(l) / CHARACTER_STORAGE_SIZE
  INTEGER(KIND=dl), PARAMETER :: sz_d = STORAGE_SIZE(d) / CHARACTER_STORAGE_SIZE
  INTEGER(KIND=dl), PARAMETER :: sz_c = STORAGE_SIZE(c) / CHARACTER_STORAGE_SIZE
  INTEGER(KIND=dl), PARAMETER :: sz_z = STORAGE_SIZE(z) / CHARACTER_STORAGE_SIZE

END MODULE mod_prec