program scauchy

!---------------------------------------------------------------------
!
!  This program is a Fortran90 implementation of a Monte Carlo Lagrangian
! algorithm to calculate realizations and statistics of stochastic Cauchy
! vorticity vectors for spacetime events selected from an online database
! of a turbulent channel flow. It was written by Gregory L. Eyink, Akshat
! Gupta, Mengze Wang, and Tamer A. Zaki. This code implements the algorithm
! proposed in:
!
! Eyink, G.L., Gupta, A. & Zaki, T.A. 2019 Stochastic Lagrangian Dynamics of
! Vorticity. I. General Theory.   http://arxiv.org/abs/1912.06677
!
! For more information on the program and its use, consult the accompanying
! file "Readme.txt"
!
!---------------------------------------------------------------------

use stdtypes
use mtprng
implicit none

    !!  PARAMETERS TO BE SET FOR STOCHASTIC LAGRANGIAN INTEGRATION

   integer, parameter :: Nsamp = 2000 ! number of stochastic Lagrangian particles (must be an even integer)
   integer, parameter :: Nstep = 2000 ! number of backward integration time steps
   real, parameter :: dt=1d-3   ! step-size for Lagrangian time-integration
   ! time of release of particles:
   real, parameter :: timef = 25.9935
   ! spatial location of release of particles:
   ! You must choose -1<x0(2)<1, in the channel interior
   ! Two examples: (a) an ejection location:
   real, parameter, dimension(3) :: x0=(/21.094707, 0.994647, 7.563944/)
   ! (b) a sweep location:
   ! real, parameter, dimension(3) :: x0=(/0.7150, 0.9951, 0.7259/)
   ! coarse-graining intervals: to eliminate coarse-graining, set px=0,py=0,pz=0
   integer, parameter ::  px=0 ! number of x-grid spacings averaged over
   integer, parameter ::  py=0 ! number of y-grid spacings averaged over
   integer, parameter ::  pz=0 ! number of z-grid spacings averaged over
   ! parameters for repeat calls to the database and restarts from checkpoints
   integer, parameter :: checkit=20  ! number of timesteps between checkpoints for restarting
   integer, parameter :: nattempts=30  ! maximum number of attempts to call the database
   integer, parameter :: tsleep=300  ! clock time in seconds between attempted calls to the database

   !!   SPECIFY YOUR ACCESS KEY HERE

   ! If you need one, please visit http://turbulence.pha.jhu.edu/
   ! (We just want to know a bit about our users!)
   character*100 :: authkey = 'edu.jhu.pha.turbulence.testing-201311' // CHAR(0)

   !! PARAMETERS TO CALL THE JHU TURBULENT CHANNEL-FLOW DATABASE (DO NOT EDIT)

   ! ---- Temporal Interpolation Options ----
   integer, parameter :: NoTInt = 0 ! No temporal interpolation
   integer, parameter :: PCHIPInt = 1 ! Piecewise cubic Hermit interpolation in time

   ! ---- Spatial Interpolation Flags for GetVelocity & GetVelocityAndPressure ----
   integer, parameter :: NoSInt = 0 ! No spatial interpolation
   integer, parameter :: Lag4 = 4 ! 4th order Lagrangian interpolation in space
   integer, parameter :: Lag6 = 6 ! 6th order Lagrangian interpolation in space
   integer, parameter :: Lag8 = 8 ! 8th order Lagrangian interpolation in space

   ! ---- Spatial Differentiation & Interpolation Flags for GetVelocityGradient & GetPressureGradient ----
   integer, parameter :: FD4NoInt = 40 ! 4th order finite differential scheme for grid values, no spatial interpolation
   integer, parameter :: FD6NoInt = 60 ! 6th order finite differential scheme for grid values, no spatial interpolation
   integer, parameter :: FD8NoInt = 80 ! 8th order finite differential scheme for grid values, no spatial interpolation
   integer, parameter :: FD4Lag4 = 44 ! 4th order finite differential scheme for grid values, 4th order Lagrangian interpolation in space

   ! ---- Spline interpolation and differentiation Flags for getVelocity,
   !      getPressure, getVelocityGradient, getPressureGradient,
   !      getVelocityHessian, getPressureHessian
   integer, parameter :: M1Q4 = 104   ! Splines with smoothness 1 (3rd order) over 4 data points. Not applicable for Hessian.
   integer, parameter :: M2Q8 = 208   ! Splines with smoothness 2 (5th order) over 8 data points.
   integer, parameter :: M2Q14 = 214  ! Splines with smoothness 2 (5th order) over 14 data points.

   !
   ! Choose which dataset to use in this query
   ! Currently, only the channel dataset is supported
   !
   character*100 :: dataset = 'channel' // CHAR(0)

   !! DATABASE SIMULATION PARAMETERS (DO NOT EDIT)

   real, parameter :: nu=5d-5  ! viscosity
   real, parameter :: dx = 0.0122656  ! x-grid spacing
   real, parameter :: dz = 0.0061328  ! z-grid spacing

   !! WORKING ARRAY DECLARATIONS

   character(len = 40) :: command
   real time
   real tdeath
   real tcross, xcross(3)
   real, dimension(3,3) :: eye
   real p0(3,1), omega0(3), ugradout9(9,1), ugrad0(3,3), omegainitial(3)
   real points(3, Nsamp), oldpoints(3,Nsamp)    ! spatial positions of particles
   integer status(Nsamp)    ! particle is off wall when status==1, on wall when status==0
   real ugrad(3,3), Xgrad(3,3)   ! temporary matrix arrays
   real history(90) ! saved trajectories of first 30 particles
   real omega(3,Nsamp), omegmn(3) ! stochastic Cauchy vorticity vectors and their mean
   real varomega(3) ! variance of the components of stochastic Cauchy vorticity vector
   real deform(3,3,Nsamp) ! deformation gradient tensors of particles
   real trace    ! trace of velocity gradient
   real, allocatable :: interior(:,:)  ! positions of interior particles
   real, allocatable :: normal(:,:)    ! normal random numbers
   real, allocatable :: dataout3(:,:)  ! results from getVelocity
   real, allocatable :: dataout9(:,:)  ! results from getVelocityGradient
   real meanposition(3), varposition(3)
   real meaninitomega, varinitialomega, temp ! initial mean and variance of vorticity
   real ygrid(512)
   integer :: it0 ! for restart
   logical :: check_exists  ! for restart
   integer :: counter, num_interior, num_interior2, Nwall
   !for stochastic interpolation of particles crossing channel wall
   real dy0, dy1, dtt, lam, mu, eta, xi, tau
   real dyy1, dyy2

   ! declarations for the Mersenne Twister prng algorithm
   real(IEEE64) :: u1, u2, n1, n2
   real(IEEE64) :: pi
   integer(INT32) :: seed
   type(mtprng_state) :: state

   real etime
   real timer(2)
   real UserTime, SystemTime, TotTime

   character(*), parameter :: fmt3 = "(3(3X,E15.8))"
   character(*), parameter :: fmt4 = "(4(3X,E15.8))"
   character(*), parameter :: fmt8 = "(8(3X,E15.8))"
   character(*), parameter :: fmt90 = "(90(3X,E15.8))"

   integer i,j,k,it,jt
   integer gridindex, gridflag

   ! For error handling
   ! Declare the return type of the turblib functions as integer.
   ! This is required for error handling
   integer :: getvelocity, getvelocitygradient
   integer, parameter :: SOAP_OK = 0  ! From stdsoap2.h
   integer rc, attempts

   !! BEGIN PROGRAM

   open(unit=20,file='input.dat',status='unknown')
   close(20)
   open(unit=20,file='input.dat',status='old')

   ! record initial time for diagnostic purposes

   TotTime    = etime(timer)
   UserTime   = timer(1)
   SystemTime = timer(2)

   ! define pi for random-number generator
   pi=datan(1d0)*4d0

   ! define identity matrix
   eye=0
   do i=1,3
      eye(i,i)=1.d0
   end do

   !
   ! Intialize the gSOAP runtime.
   ! This is required before any WebService routines are called.
   !
   CALL soapinit()
   CALL turblibSetExitOnError(0)

   ! INQUIRE WHETHER CHECKPOINT EXISTS
   inquire(file='checkpoint/seed.dat', exist=check_exists)

   !!! INITIALIZE
   if (.not.check_exists) then

      !
      !   set seed for random number generator
      !
      open(89,file='/dev/random',access='stream',form='UNFORMATTED')
      read(89) seed
      close(89)
      write(*,*) 'seed', seed

      write(20,*) 'seed=', seed
      write(20,*) 'Nsamp=', Nsamp
      write(20,*) 'Nstep=', Nstep
      write(20,*) 'timef=', timef
      write(20,*) 'dt=', dt
      write(20,*) 'x0=', x0(1),'  y0=', x0(2),'  z0=', x0(3)
      write(20,*) 'px=', px, '  py=', py,'  pz=', pz

      open (unit = 222, file = "y.txt")
      read(222,*) ygrid
      close(222)

      call mtprng_init(seed,state)

      ! Find grid points between which selected point lies
      gridflag = 0
      gridindex = 1
      do while (gridflag.ne.1)
         if ((x0(2) .gt. ygrid(gridindex)) .and. (x0(2) .le. ygrid(gridindex+1))) then
            gridflag = 1
         else
            gridindex = gridindex + 1
         end if
      end do
      write(*,*) 'gridindex = ', gridindex,ygrid(gridindex),x0(2),ygrid(gridindex+1)

      ! Find grid point closest to selected point
      if ((x0(2)-ygrid(gridindex)) .gt. (ygrid(gridindex+1)-x0(2))) then
         gridindex=gridindex+1
      end if

      ! DEFINITION OF INTERVAL FOR COARSE-GRAINING IN Y-DIRECTION
      !centering at the closest grid point, take distances to next py/2-th grid points
      if (mod(py,2).eq.0) then
         dyy1 = ygrid(gridindex) - ygrid(gridindex-py/2)
         dyy2 = ygrid(gridindex+py/2) - ygrid(gridindex)
      else
         dyy1 = (ygrid(gridindex) - ygrid(gridindex-(py-1)/2))+(ygrid(gridindex-(py-1)/2)-ygrid(gridindex-(py+1)/2))/2.0
         dyy2 = (ygrid(gridindex+(py-1)/2) - ygrid(gridindex))+(ygrid(gridindex+(py+1)/2)-ygrid(gridindex+(py-1)/2))/2.0
      end if

      it0=0
      num_interior=Nsamp
      allocate ( dataout3(3,Nsamp))
      allocate ( dataout9(9,Nsamp))

      deform=0
      do i = 1, Nsamp, 1
         status(i)=1
         oldpoints(1,i) = x0(1) - px*dx/2 + mtprng_rand_real3(state)*px*dx;
         oldpoints(2,i) = x0(2) - dyy1 + mtprng_rand_real3(state)*(dyy1 +dyy2);
         oldpoints(3,i) = x0(3) - pz*dz/2 + mtprng_rand_real3(state)*pz*dz;
         do j=1,3
            deform(j,j,i)=1.d0
            if (i .lt. 31) then
               history(j+3*(i-1))=oldpoints(j,i)
            end if
         end do
      end do

      time=timef

      ! CALCULATE INITIAL MEAN VORTICITY AND PARTICLE POSITION MEAN & VARIANCE

      ! get velocity at initial particle locations
      attempts=0
      do while (getvelocity(authkey, dataset, time, Lag6, PCHIPInt, num_interior, oldpoints, dataout3).ne.0)
         attempts = attempts + 1
         if (attempts.ge.30) then
            write(*,*) 'Fatal error: too many failures'
            CALL turblibPrintError()
            STOP
         else
            write(*,*) 'Temporary Error (#', attempts, '):'
            CALL turblibPrintError()
            CALL sleep(5)
         end if
      end do

      ! get velocity gradient at initial particle locations
      attempts=0
      do while (getvelocitygradient(authkey, dataset, time, FD4Lag4, PCHIPInt, num_interior, oldpoints, dataout9).ne.0)
         attempts = attempts + 1
         if (attempts.ge.30) then
            write(*,*) 'Fatal error: too many failures'
            CALL turblibPrintError()
            STOP
         else
            write(*,*) 'Temporary Error (#', attempts, '):'
            CALL turblibPrintError()
            CALL sleep(5)
         end if
      end do

      ! CALCULATE MEAN INITIAL VORTICITY AND POSITION
      do i=1,3
         omegmn(i)=0.0d0
         meanposition(i)=0.0d0
      end do

      do i = 1, Nsamp
         do j=1,3
            meanposition(j) = meanposition(j) + oldpoints(j,i)
         end do

         ! CALCULATE INITIAL CAUCHY INVARIANT CONTRIBUTIONS
         ugrad(1,1)=dataout9(1,i); ugrad(1,2)=dataout9(2,i);ugrad(1,3)=dataout9(3,i)
         ugrad(2,1)=dataout9(4,i); ugrad(2,2)=dataout9(5,i);ugrad(2,3)=dataout9(6,i)
         ugrad(3,1)=dataout9(7,i); ugrad(3,2)=dataout9(8,i);ugrad(3,3)=dataout9(9,i)

         ! Calculate and subtract the trace
         trace=0
         do jt = 1,3
            trace = trace + ugrad(jt,jt)
         end do
         ugrad=ugrad-(trace*eye)/3

         ! Calculate vorticity at current time
         ugrad=ugrad-transpose(ugrad)
         omega0(1)=ugrad(3,2); omega0(2)=ugrad(1,3); omega0(3)=ugrad(2,1)

         do j=1,3
            omega(j,i)=omega0(j)
         end do
         ! VORTICITY FOR INITIAL PARTICLES IS NOW STORED

         do j=1,3
            omegmn(j)=omegmn(j)+omega(j,i)
         end do
      end do

      do i=1,3
         omegmn(i)=omegmn(i)/Nsamp
         meanposition(i)=meanposition(i)/Nsamp
      end do
      write(20,*) omegmn(1), omegmn(2), omegmn(3)
      close(20)

      meaninitomega = sqrt(omegmn(1)*omegmn(1) + omegmn(2)*omegmn(2) + omegmn(3)*omegmn(3))
      !! DEFINE UNIT VECTOR IN DIRECTION OF MEAN VORTICITY, omegainitial
      do i=1,3
         omegainitial(i)=omegmn(i)/meaninitomega
      end do

      ! CALCULATE VARIANCE OF INITIAL VORTICITY AND POSITION
      do i=1,3
         varomega(i)=0.0d0
         varposition(i)=0.0d0
      end do
      varinitialomega=0.0d0

      do i = 1, Nsamp
         temp = meaninitomega - (omega(1,i)*omegainitial(1) + omega(2,i)*omegainitial(2) + omega(3,i)*omegainitial(3))
         varinitialomega = varinitialomega + temp*temp
         do j = 1,3
            varomega(j) = varomega(j) + (omega(j,i) -omegmn(j))*(omega(j,i)-omegmn(j))
            varposition(j) = varposition(j) + (oldpoints(j,i) -meanposition(j))*(oldpoints(j,i) - meanposition(j))
         end do
      end do
      varinitialomega=varinitialomega/(Nsamp-1)
      do i=1,3
         varomega(i)=varomega(i)/(Nsamp-1)
         varposition(i)=varposition(i)/(Nsamp-1)
      end do

      open(10, file='wallparticles.dat', status='new', action='write',position='append')
      open(unit = 11, file='varposition.dat', status='new', action='write',position='append')
      write(11,fmt3) varposition(1), varposition(2), varposition(3)
      open(12, file='varomega.dat', status='new', action='write',position='append')
      write(12,fmt4) varomega(1), varomega(2), varomega(3), varinitialomega
      open(15, file='meanposition.dat', status='new', action='write', position='append')
      write(15,fmt4) time, meanposition(1), meanposition(2), meanposition(3)
      open(30, file='omegamn.dat', status='new', action='write',position='append')
      write(30,fmt4) time, omegmn(1), omegmn(2), omegmn(3)
      open(40, file='history.dat', status='new', action='write',position='append')
      write(40,fmt90) (history(k), k=1,90)

      command = 'cp wallparticles.dat checkpoint'
      CALL system(command)
      command = 'cp varposition.dat checkpoint'
      CALL system(command)
      command = 'cp varomega.dat checkpoint'
      CALL system(command)
      command = 'cp meanposition.dat checkpoint'
      CALL system(command)
      command = 'cp omegamn.dat checkpoint'
      CALL system(command)
      command = 'cp history.dat checkpoint'
      CALL system(command)

      ! SAVE INITIAL VALUES
      open(21, file='checkpoint/seed.dat', form='unformatted', status='replace')
      write(21) seed
      close(21)
      open(21, file='checkpoint/omegainitial.dat', form='unformatted', status='replace')
      write(21) omegainitial
      close(21)

      ! SAVE CHECKPOINT
      open(22, file='checkpoint/state.dat', form='unformatted', status='replace')
      write(22) state
      close(22)
      open(23, file='checkpoint/iterate.dat', form='unformatted', status='replace')
      write(23) it0
      close(23)
      open(24, file='checkpoint/num_interior.dat', form='unformatted', status='replace')
      write(24) num_interior
      close(24)
      open(25, file='checkpoint/points.dat', form='unformatted', status='replace')
      write(25) oldpoints
      close(25)
      open(26, file='checkpoint/status.dat', form='unformatted', status='replace')
      write(26) status
      close(26)
      open(27, file='checkpoint/deform.dat', form='unformatted', status='replace')
      write(27) deform
      close(27)
      open(28, file='checkpoint/omega.dat', form='unformatted', status='replace')
      write(28) omega
      close(28)

   !!! RESTARTING
   else

      ! READ IN INITIAL VALUES
      open(21, file='checkpoint/seed.dat', form='unformatted', status='old')
      read(21) seed
      close(21)
      write(*,*) 'seed=', seed
      open(21, file='checkpoint/omegainitial.dat', form='unformatted', status='old')
      write(21) omegainitial
      close(21)

      ! READ IN CHECKPOINT
      open(22, file='checkpoint/state.dat', form='unformatted', status='old')
      read(22) state
      close(22)
      open(23, file='checkpoint/iterate.dat', form='unformatted', status='old')
      read(23) it0
      close(23)
      time=timef-dfloat(it0)*dt
      write(*,*) 'time=', time
      open(24, file='checkpoint/num_interior.dat', form='unformatted', status='old')
      read(24) num_interior
      close(24)
      write(*,*) 'num_interior=', num_interior
      open(25, file='checkpoint/points.dat', form='unformatted', status='old')
      read(25) oldpoints
      close(25)
      open(26, file='checkpoint/status.dat', form='unformatted', status='old')
      read(26) status
      close(26)
      open(27, file='checkpoint/deform.dat', form='unformatted', status='old')
      read(27) deform
      close(27)
      open(28, file='checkpoint/omega.dat', form='unformatted', status='old')
      read(28) omega
      close(28)

      ! OPEN DATA FILES
      command = 'cp checkpoint/wallparticles.dat .'
      CALL system(command)
      command = 'cp checkpoint/varposition.dat .'
      CALL system(command)
      command = 'cp checkpoint/varomega.dat .'
      CALL system(command)
      command = 'cp checkpoint/meanposition.dat .'
      CALL system(command)
      command = 'cp checkpoint/omegamn.dat .'
      CALL system(command)
      command = 'cp checkpoint/history.dat .'
      CALL system(command)

      open(10, file='wallparticles.dat', status='old', action='write', position='append')
      open(11, file='varposition.dat', status='old', action='write', position='append')
      open(12, file='varomega.dat', status='old', action='write', position='append')
      open(15, file='meanposition.dat', status='old', action='write', position='append')
      open(30, file='omegamn.dat', status='old', action='write', position='append')
      open(40, file='history.dat', status='old', action='write', position='append')

      counter=1
      allocate ( interior(3,num_interior))
      do i = 1, Nsamp
         ! fill array interior
         if (status(i) .eq. 1) then
            do j=1,3
               interior(j,counter) = oldpoints(j,i)
            end do
            counter=counter+1
         end if
      end do

      allocate ( dataout3(3,num_interior))
      allocate ( dataout9(9,num_interior))

      ! get velocity at interior particle locations
      attempts=0
      do while (getvelocity(authkey, dataset, time, Lag6, PCHIPInt, num_interior, interior, dataout3).ne.0)
        attempts = attempts + 1
        if (attempts.ge.nattempts) then
          write(*,*) 'Fatal error: too many failures'
          CALL turblibPrintError()
          STOP
        else
          write(*,*) 'Temporary Error (#', attempts, '):'
          CALL turblibPrintError()
          CALL sleep(tsleep)
        end if
      end do

      ! get velocity gradient at interior particle locations
      attempts=0
      do while (getvelocitygradient(authkey, dataset, time, FD4Lag4, PCHIPInt, num_interior, interior, dataout9).ne.0)
      attempts = attempts + 1
        if (attempts.ge.nattempts) then
          write(*,*) 'Fatal error: too many failures'
          CALL turblibPrintError()
          STOP
        else
          write(*,*) 'Temporary Error (#', attempts, '):'
          CALL turblibPrintError()
          CALL sleep(tsleep)
        end if
      end do

      deallocate (interior)

   ! END INITIALIZATION
   end if

   !!! MAIN INTEGRATION LOOP BACKWARD IN TIME
   do it=it0+1,Nstep
      ! write current time-step to screen; comment out this command to eliminate screen ouput
      write(*,*) it

      if (mod(num_interior,2).eq.0) then
         num_interior2=num_interior
      else
         num_interior2=num_interior+1
      end if

      allocate ( normal(3,num_interior2))

      ! Generate an array of 3*num_interior2 normal random numbers
      do i = 1, num_interior2-1, 2
         do j=1,3
            u1=mtprng_rand_real3(state)
            u2=mtprng_rand_real3(state)
            ! Box-Muller transform
            normal(j,i)=sngl(dsqrt(-2.0d0*dlog(u1))*dcos(2.0d0*pi*u2))
            normal(j,i+1)=sngl(dsqrt(-2.0d0*dlog(u1))*dsin(2.0d0*pi*u2))
         end do
      end do

      counter=1
      Nwall=0
      !! INTEGRATE INTERIOR PARTICLES ONE STEP BACKWARD IN TIME AND FIND WHICH NEWLY HIT THE WALL
      do i = 1, Nsamp

         ! Euler-Maruyama integration backward in time for interior points
         if (status(i) .eq. 1) then

            ! eqn(3.1)
            do j=1,3
               points(j,i) = oldpoints(j,i) - dt*dataout3(j,counter) + sqrt(2.0*nu*dt)*normal(j,counter)
            end do

            ! UPDATE DEFORMATION MATRIX FOR PARTICLES THAT REMAIN INTERIOR
            if((points(2,i) .gt. -1) .and. (points(2,i) .lt. 1)) then

               ugrad(1,1)=dataout9(1,counter); ugrad(1,2)=dataout9(2,counter); ugrad(1,3)=dataout9(3,counter)
               ugrad(2,1)=dataout9(4,counter); ugrad(2,2)=dataout9(5,counter); ugrad(2,3)=dataout9(6,counter)
               ugrad(3,1)=dataout9(7,counter); ugrad(3,2)=dataout9(8,counter); ugrad(3,3)=dataout9(9,counter)

               !Calculating and subtracting the trace
               trace=0d0
               do jt = 1,3
                  trace = trace + ugrad(jt,jt)
               end do
               ugrad=ugrad-(trace*eye)/3

               Xgrad(1,1)=deform(1,1,i); Xgrad(1,2)=deform(1,2,i); Xgrad(1,3)=deform(1,3,i)
               Xgrad(2,1)=deform(2,1,i); Xgrad(2,2)=deform(2,2,i); Xgrad(2,3)=deform(2,3,i)
               Xgrad(3,1)=deform(3,1,i); Xgrad(3,2)=deform(3,2,i); Xgrad(3,3)=deform(3,3,i)

               ! Euler integration backward in time for deformation matrix
               ! See eqn(3.4) in the paper
               Xgrad=matmul(Xgrad,eye+dt*ugrad)

               deform(1,1,i)=Xgrad(1,1); deform(1,2,i)=Xgrad(1,2); deform(1,3,i)=Xgrad(1,3)
               deform(2,1,i)=Xgrad(2,1); deform(2,2,i)=Xgrad(2,2); deform(2,3,i)=Xgrad(2,3)
               deform(3,1,i)=Xgrad(3,1); deform(3,2,i)=Xgrad(3,2); deform(3,3,i)=Xgrad(3,3)

            ! CALCULATE FINAL CONTRIBUTIONS FOR NEW WALL PARTICLES
            else

               ! stochastic estimation of hitting time
               ! See appendix A of paper
               if((points(2,i) .ne. -1) .and. (points(2,i) .ne. 1)) then
                  ! change of coordinates
                  ! dy0, dy1 are b0, b1 in appendix A
                  if( points(2,i) .le. -1) then
                     dy0=1+oldpoints(2,i)
                     dy1=1+points(2,i)
                     points(2,i) = -1
                     xcross(2) = -1
                  else
                     dy0=1-oldpoints(2,i)
                     dy1=1-points(2,i)
                     points(2,i) = 1
                     xcross(2) = 1
                  end if

                  ! See eqn(A.10) in paper
                  lam=dy0**2/(2*nu*dt)
                  mu=-dy0/dy1

                  ! See eqn(A.11, A.12) in paper
                  u1=mtprng_rand_real3(state)
                  u2=mtprng_rand_real3(state)
                  n1=sqrt(-2.0d0*dlog(u1))*dcos(2.0d0*pi*u2)
                  u1=mtprng_rand_real3(state)
                  eta=sngl(n1**2)
                  xi=mu*eta-sqrt(abs(4*mu*lam*eta+(mu**2)*(eta**2)))
                  xi=mu*(1+xi/(2*lam))
                  if (u1 .le. mu/(mu+xi)) then
                      tau=xi
                  else
                      tau=mu**2/xi
                  end if
                  dtt=tau*dt/(1d0+tau)
                  tcross=time-dtt

                  ! stochastic estimation of xz locations
                  u1=mtprng_rand_real3(state)
                  u2=mtprng_rand_real3(state)
                  n1=dsqrt(-2.0d0*dlog(u1))*dcos(2.0d0*pi*u2)
                  n2=dsqrt(-2.0d0*dlog(u1))*dsin(2.0d0*pi*u2)
                  ! See eqn(A.18) in paper
                  xcross(1) = (points(1,i)*dtt + oldpoints(1,i)*(dt-dtt))/dt + sqrt(abs(2*sngl(nu)*tau*dt))*sngl(n1)/(1+tau)
                  ! See eqn(A.19) in paper
                  xcross(3) = (points(3,i)*dtt + oldpoints(3,i)*(dt-dtt))/dt + sqrt(abs(2*sngl(nu)*tau*dt))*sngl(n2)/(1+tau)
                  points(1,i) = xcross(1)
                  points(3,i) = xcross(3)
               end if

               tdeath=tcross
               status(i)=0
               Nwall=Nwall+1

               ! UPDATE DEFORMATION MATRIX FOR NEW WALL PARTICLES
               ugrad(1,1)=dataout9(1,counter); ugrad(1,2)=dataout9(2,counter); ugrad(1,3)=dataout9(3,counter)
               ugrad(2,1)=dataout9(4,counter); ugrad(2,2)=dataout9(5,counter); ugrad(2,3)=dataout9(6,counter)
               ugrad(3,1)=dataout9(7,counter); ugrad(3,2)=dataout9(8,counter); ugrad(3,3)=dataout9(9,counter)

               ! Calculate and subtract the trace
               trace=0d0
               do jt = 1,3
                  trace = trace + ugrad(jt,jt)
               end do
               ugrad=ugrad-(trace*eye)/3

               Xgrad(1,1)=deform(1,1,i); Xgrad(1,2)=deform(1,2,i); Xgrad(1,3)=deform(1,3,i)
               Xgrad(2,1)=deform(2,1,i); Xgrad(2,2)=deform(2,2,i); Xgrad(2,3)=deform(2,3,i)
               Xgrad(3,1)=deform(3,1,i); Xgrad(3,2)=deform(3,2,i); Xgrad(3,3)=deform(3,3,i)

               ! Euler integration backward in time for deformation matrix
               Xgrad=matmul(Xgrad,eye+dtt*ugrad)

               deform(1,1,i)=Xgrad(1,1); deform(1,2,i)=Xgrad(1,2); deform(1,3,i)=Xgrad(1,3)
               deform(2,1,i)=Xgrad(2,1); deform(2,2,i)=Xgrad(2,2); deform(2,3,i)=Xgrad(2,3)
               deform(3,1,i)=Xgrad(3,1); deform(3,2,i)=Xgrad(3,2); deform(3,3,i)=Xgrad(3,3)

               ! CALL DATABASE FOR VORTICITY AND CALCULATE CAUCHY INVARIANT CONTRIBUTION FOR NEW WALL PARTICLES

               ! get velocity gradient at new wall particle location
               p0(1,1)=xcross(1); p0(2,1)=xcross(2); p0(3,1)=xcross(3);
               attempts=0
               do while (getvelocitygradient(authkey, dataset, tcross, FD4Lag4, PCHIPInt,1,p0, ugradout9).ne.0)
                  attempts = attempts + 1
                  if (attempts.ge.nattempts) then
                     write(*,*) 'Fatal error: too many failures'
                     CALL turblibPrintError()
                     STOP
                  else
                     write(*,*) 'Temporary Error (#', attempts, '):'
                     CALL turblibPrintError()
                     CALL sleep(tsleep)
                  end if
               end do

               ugrad(1,1)=ugradout9(1,1); ugrad(1,2)=ugradout9(2,1); ugrad(1,3)=ugradout9(3,1)
               ugrad(2,1)=ugradout9(4,1); ugrad(2,2)=ugradout9(5,1); ugrad(2,3)=ugradout9(6,1)
               ugrad(3,1)=ugradout9(7,1); ugrad(3,2)=ugradout9(8,1); ugrad(3,3)=ugradout9(9,1)

               ! Calculate and subtract the trace
               trace=0d0
               do jt = 1,3
               trace = trace + ugrad(jt,jt)
               end do
               ugrad=ugrad-(trace*eye)/3

               ! calculate Cauchy vorticity vector for new wall particle
               ugrad=ugrad-transpose(ugrad)
               omega0(1)=ugrad(3,2); omega0(2)=ugrad(1,3); omega0(3)=ugrad(2,1)
               omega0=matmul(Xgrad,omega0)

               do j=1,3
                  omega(j,i)=omega0(j)
               end do
               write(10,fmt8) real(i), tdeath, xcross(1), xcross(2), xcross(3), omega0(1), omega0(2), omega0(3)
            end if

            counter = counter+1

         ! keep points the same for wall particles
         else

            do j = 1,3
               points(j,i) = oldpoints(j,i)
            end do

         end if

         ! CREATE VECTOR FOR HISTORY OF FIRST 30 PARTICLES
         do j=1,3
         if (i .lt. 31) then
            history(j+3*(i-1))=points(j,i)
         end if
         end do

      !! END ONE BACKWARD INTEGRATION STEP
      end do

      time=time-dt
      deallocate (normal)
      deallocate(dataout3)
      deallocate(dataout9)
      num_interior=num_interior-Nwall

      !! GET VELOCITIES AND VELOCITY-GRADIENTS FOR ALL INTERIOR PARTICLES
      counter=1
      allocate ( interior(3,num_interior))
      do i = 1, Nsamp
         ! fill array interior
         if (status(i) .eq. 1) then
            do j=1,3
              interior(j,counter) = points(j,i)
            end do
            counter=counter+1
         end if
      end do

      allocate ( dataout3(3,num_interior))
      allocate ( dataout9(9,num_interior))

      ! get velocity at interior particle locations
      attempts=0
      do while (getvelocity(authkey, dataset, time, Lag6, PCHIPInt, num_interior, interior, dataout3).ne.0)
         attempts = attempts + 1
         if (attempts.ge.nattempts) then
            write(*,*) 'Fatal error: too many failures'
            CALL turblibPrintError()
            STOP
         else
            write(*,*) 'Temporary Error (#', attempts, '):'
            CALL turblibPrintError()
            CALL sleep(tsleep)
         end if
      end do

      ! get velocity gradient at interior particle locations
      attempts=0
      do while (getvelocitygradient(authkey, dataset, time, FD4Lag4, PCHIPInt, num_interior, interior, dataout9).ne.0)
         attempts = attempts + 1
         if (attempts.ge.nattempts) then
            write(*,*) 'Fatal error: too many failures'
            CALL turblibPrintError()
            STOP
         else
            write(*,*) 'Temporary Error (#', attempts, '):'
            CALL turblibPrintError()
            CALL sleep(tsleep)
         end if
      end do

      deallocate (interior)

      ! CALCULATE ENSEMBLE AVERAGE CAUCHY VORTICITY STATISTICS AT NEW TIME
      do i=1,3
         omegmn(i)=0.0d0
         varomega(i)=0.0d0
         meanposition(i)=0.0d0
         varposition(i)=0.0d0
      end do
      meaninitomega=0.0d0
      varinitialomega=0.0d0
      counter=1
      do i = 1, Nsamp
         do j=1,3
            meanposition(j) = meanposition(j) + points(j,i)
         end do

         ! CALCULATE NEW CAUCHY INVARIANT CONTRIBUTION FOR INTERIOR PARTICLES
         if (status(i) .eq. 1) then
            ugrad(1,1)=dataout9(1,counter); ugrad(1,2)=dataout9(2,counter); ugrad(1,3)=dataout9(3,counter)
            ugrad(2,1)=dataout9(4,counter); ugrad(2,2)=dataout9(5,counter); ugrad(2,3)=dataout9(6,counter)
            ugrad(3,1)=dataout9(7,counter); ugrad(3,2)=dataout9(8,counter); ugrad(3,3)=dataout9(9,counter)

            ! Calculate and subtract the trace
            trace=0
            do jt = 1,3
             trace = trace + ugrad(jt,jt)
            end do
            ugrad=ugrad-(trace*eye)/3

            ! Calculate vorticity at current time
            ugrad=ugrad-transpose(ugrad)
            omega0(1)=ugrad(3,2); omega0(2)=ugrad(1,3); omega0(3)=ugrad(2,1)

            ! Calculate Cauchy vorticity vector at current time
            Xgrad(1,1)=deform(1,1,i); Xgrad(1,2)=deform(1,2,i); Xgrad(1,3)=deform(1,3,i)
            Xgrad(2,1)=deform(2,1,i); Xgrad(2,2)=deform(2,2,i); Xgrad(2,3)=deform(2,3,i)
            Xgrad(3,1)=deform(3,1,i); Xgrad(3,2)=deform(3,2,i); Xgrad(3,3)=deform(3,3,i)
            omega0=matmul(Xgrad,omega0)

            do j=1,3
               omega(j,i)=omega0(j)
            end do
            ! NEW CAUCHY VORTICITY VECTOR FOR INTERIOR PARTICLE NOW STORED
            counter=counter+1
         end if

         do j=1,3
            omegmn(j)=omegmn(j)+omega(j,i)
         end do
         meaninitomega = meaninitomega + omega(1,i)*omegainitial(1) + omega(2,i)*omegainitial(2) + omega(3,i)*omegainitial(3)

      end do

      meaninitomega=meaninitomega/Nsamp
      do i=1,3
         omegmn(i)=omegmn(i)/Nsamp
         meanposition(i)=meanposition(i)/Nsamp
      end do
      do i = 1, Nsamp
         temp = meaninitomega - (omega(1,i)*omegainitial(1) + omega(2,i)*omegainitial(2) + omega(3,i)*omegainitial(3))
         varinitialomega = varinitialomega + temp*temp
         do j = 1,3
            oldpoints(j,i) = points(j,i)
            varomega(j) = varomega(j) + (omega(j,i) -omegmn(j))*(omega(j,i) -omegmn(j))
            varposition(j) = varposition(j) + (points(j,i) - meanposition(j))*(points(j,i) - meanposition(j))
         end do
      end do
      varinitialomega=varinitialomega/(Nsamp-1)
      do i=1,3
         varomega(i)=varomega(i)/(Nsamp-1)
         varposition(i)=varposition(i)/(Nsamp-1)
      end do

      write(11,fmt3) varposition(1), varposition(2), varposition(3)
      write(12,fmt4) varomega(1), varomega(2), varomega(3), varinitialomega
      write(15,fmt4) time, meanposition(1), meanposition(2), meanposition(3)
      write(30,fmt4) time, omegmn(1), omegmn(2), omegmn(3)
      write(40,fmt90) (history(k), k=1,90)

      ! REPLACE CHECKPOINT FILES
      if (mod(it,checkit).eq.0) then

         open(22, file='checkpoint/state.dat', form='unformatted', status='replace')
         write(22) state
         close(22)
         open(23, file='checkpoint/iterate.dat', form='unformatted', status='replace')
         write(23) it
         close(23)
         open(24, file='checkpoint/num_interior.dat', form='unformatted', status='replace')
         write(24) num_interior
         close(24)
         open(25, file='checkpoint/points.dat', form='unformatted', status='replace')
         write(25) points
         close(25)
         open(26, file='checkpoint/status.dat', form='unformatted', status='replace')
         write(26) status
         close(26)
         open(27, file='checkpoint/deform.dat', form='unformatted', status='replace')
         write(27) deform
         close(27)
         open(28, file='checkpoint/omega.dat', form='unformatted', status='replace')
         write(28) omega
         close(28)

         command = 'cp wallparticles.dat checkpoint'
         CALL system(command)
         command = 'cp varposition.dat checkpoint'
         CALL system(command)
         command = 'cp varomega.dat checkpoint'
         CALL system(command)
         command = 'cp meanposition.dat checkpoint'
         CALL system(command)
         command = 'cp omegamn.dat checkpoint'
         CALL system(command)
         command = 'cp history.dat checkpoint'
         CALL system(command)

      end if

   ! END MAIN INTEGRATION LOOP
   end do

   write(71,*) 'completed'
   close(10)
   close(11)
   close(12)
   close(15)
   close(30)
   close(40)

   deallocate ( dataout3)
   deallocate ( dataout9)

   TotTime    = etime(timer)
   UserTime   = timer(1)
   SystemTime = timer(2)

   ! print *,'Total time:', TotTime, 'secs'
   ! print *,'System time:', SystemTime, 'secs'
   ! print *,'User time:', UserTime, 'secs'

   ! Destroy the gSOAP runtime.
   ! No more WebService routines may be called.
   !
   CALL soapdestroy()

end program scauchy


                    subroutine inqradc(raline, decline, rh, rm, rs,
     +                                 isign, dd, dm, ds, ras, dec)
*
*     reads right ascension HHMMSS.SSS and declination +/-DDMMSS.SSS
*     from the console and returns the values 'rh', 'rm', 'rs', 'isign',
*     'dd', 'dm' and 'ds', as well as 'ras' and 'dec' in degrees.
*
      implicit real * 8 (a - h, o - z)
*
      character raline * 70 , decline * 70
*
C      write (*, *) 'Enter right ascention in HH MM SS.SSS'
C      read (*, '(A70)') aline
*
         do 50 i = 1, 70
*
          if (raline(i : i) .eq. ':') then
           raline(i : i) = ' '
          endif
*
50      continue
*
      read (raline, *, iostat = istat) rh, rm, rs
*
      if (istat .ne. 0) then
        write (*, *) 'inqradc : read error! ', raline
        stop
      elseif (rh .lt. 0.0d0 .or. rh .gt. 24.0d0) then
        write (*, *) 'inqradc : RA hour out of range!  rh = ',
     +               rh
        stop
      else if (rm .lt. 0.0d0 .or. rm .gt. 60.0d0) then
        write (*, *) 'inqradc : RA minutes out of range!  rm = ',
     +               rm
        stop
      else if (rs .lt. 0.0d0 .or. rs .gt. 60.0d0) then
        write (*, *) 'inqradc : RA second out of range!   rs = ',
     +               rs
        stop
      endif
*
C      write (*, *) 'Enter declination in +/- DD MM SS.SSS'
*
C      read (*, '(A70)') aline

        do 60 i = 1, 70
*
         if (decline(i : i) .eq. ':') then
          decline(i : i) = ' '
         endif
*
60    continue
*
      do 100 i = 1, 70
*
        if (decline(i : i) .ne. ' ') then
          go to 200
        endif
*
 100  continue
*
      write (*, *) 'inqradc : Too many blanks in decline "', decline,
     +             '"'
      stop
*
 200  continue
*
      if (decline(i : i) .eq. '-') then
        isign = -1
        i = i + 1
      else if (decline(i : i) .eq. '+') then
        isign = 1
        i = i + 1
      else
        isign = 1
      endif
*
**      write (*, *) 'sign = "', aline(i - 1 : i - 1), '"'
*
      read (decline(i : 70), *, iostat = istat) dd, dm, ds
*
      if (istat .ne. 0) then
        write (*, *) 'inqradc : read error! ', decline
        stop
      elseif (dd .lt. 0.0d0 .or. dd .gt. 90.0d0) then
        write (*, *) 'inqradc : DEC degree out of range!  dd = ',
     +               dd
        stop
      else if (dm .lt. 0.0d0 .or. dm .gt. 60.0d0) then
        write (*, *) 'inqradc : DEC minutes out of range!  dm = ',
     +               dm
        stop
      else if (ds .lt. 0.0d0 .or. ds .gt. 60.0d0) then
        write (*, *) 'inqradc : DEC second out of range!   ds = ',
     +               ds
        stop
      endif
*
      ras = 15.0d0 * (rh + rm / 60.0d0 + rs / 3600.0d0)
      dec = isign  * (dd + dm / 60.0d0 + ds / 3600.0d0)
*
      return
      end


program tpslq3

!   Test program for PSLQ3 -- a three-level implementation of the standard
!   PSLQ algorithm for finding integer relations.  Fortran-90 ARPREC version.

!   David H. Bailey     2004-11-23

!   These parameters are set in the parameter statement below.  Some other
!   parameters are set in other routines.

!     idb = Debug level (0 - 4).
!     itr = Number of trials when KQ = 1, 2 or 3.
!     gam = Gamma, the PSLQ algorithm parameter.  Must be set to at least
!           Sqrt (4/3) = 1.154700538.
!     n   = Integer relation vector length.
!     kq  = 0 for the algebraic case [1, al, al^2, ... al^(n-1)], where
!           al = 3^(1/kr) - 2^(1/ks).  Set n = kr * ks + 1 and itr = 1.
!         = 1 for testing algebraic relations of a number read from a file.
!         = 2 for testing additive relations of numbers read from a file.
!         = 3 for testing multiplicative relations of numbers read from a file.
!         = 4 for custom input.
!     kr  = Degree of root of 3 when kq = 0.
!     ks  = Degree of root of 2 when kq = 0.
!     ndp = No. digits of pecision.  Must not exceed mpipl in mpmod90.f.
!           It is recommended that this be set to at least 120 digits more
!           than the expected detection level of the relation.
!     nep = Log10 of epsilon for detections.  Normally set to 30 - ndp or so.
!           Must not exceed the accuracy of input data.
!     rb  = Log10 of max size (Euclidean norm) of acceptable relation.

use mpmodule
use mpmodulem
implicit none
double precision d1, d2, drand, dw, gam, rb, rm, second, tm, tm0, tm1
integer i, idb, iq, itr, j, k, kps, kcs, kq, kr, ks, kss, n, ndp, nep
parameter (idb = 2, itr = 1, gam = 1.154700538d0, kq = 0, kr = 7, ks = 8, &
  n = kr * ks + 1, ndp = 780, nep = -760, rb = 100.d0)
character*1 chr1(100)
character*40 nam(n), namx
integer lnm(n)
double precision dr(n), r1(n)
type (mp_real) al, t1, t2, r(n), x(n)

!   This is scratch space for pslq3.  See below.

integer is0(n)
double precision s1(6*n*n+3*n)
type (mp_realm) s2(3*n*n+2*n)
type (mp_real) s3(2*n*n+2*n)
save

call mpinit (ndp)
mpoud = 100
mpeps = mpreal (10) ** nep
write (6, 1) itr, gam, n, kq, kr, ks, rb, ndp, nep
1 format ('PSLQ3 Test Program'/'No. trials = ',i3,3x,'Gamma =',f12.9, &
  3x,'n =',i4,3x,'kq =',i2/'kr =',i2,3x,'ks =',i2,3x,'rb =',1p,d12.4/ &
  'Precision level ndp =',i6,' digits',3x,'Epsilon level nep = ',i6)
tm = 0.d0
kps = 0
kcs = 0
if (kq .eq. 1 .or. kq .eq. 2 .or. kq .eq. 3) then
  open (11, file = 'pslq.inp')
  rewind 11
endif

do k = 1, itr
  write (6, 2) k
2 format (/'Start trial', i3)

  if (kq .eq. 0) then

!   This code generates al = 3^(1/kr) - 2^(1/ks).  al is algebraic of degree
!   kr * ks.  Set n = kr * ks + 1 to recover the polynomial satisfied by al.

    al = mpnrtf (mpreal (3.d0), kr) - mpnrtf (mpreal (2.d0), ks)
  elseif (kq .eq. 1) then

!   Read an algebraic constant from a file.

    call mpread (11, al)
  elseif (kq .eq. 2) then

!   Read constants from a file for additive test.

    do i = 1, n
      call mpread (11, al)
      x(i) = al
      write (namx, '(''con'',i3.3)') i
      nam(i) = namx(1:6)
      lnm(i) = 6
    enddo
  elseif (kq .eq. 3) then

!   Read constants from a file for multiplicative test.

    do i = 1, n
      call mpread (11, al)
      x(i) = log (al)
      write (namx, '(''log(con'',i3.3,'')'')') i
      nam(i) = namx(1:11)
      lnm(i) = 11
    enddo
  elseif (kq .eq. 4) then

!   Produce X vector by a custom scheme.

  endif

!   If kq is 0 or 1, generate x = [1, al, al^2, ..., al^(n-1)].

  if (kq .eq. 0 .or. kq .eq. 1) then
    x(1) = 1.d0
    nam(1) = '1'
    lnm(1) = 1

    do i = 2, n
      x(i) = al * x(i-1)
      write (namx, '(''al^'',i3)') i - 1
      nam(i) = namx(1:6)
      lnm(i) = 6
    enddo
  endif

!   Perform relation search.

  tm0 = second ()
  call pslq3 (idb, gam, n, rb, x, is0, s1, s2, s3, iq, r)
  tm1 = second ()

!   Output relation, if one was found.

  if (iq .ne. 0) then
    tm = tm + (tm1 - tm0)
    write (6, 4)
4   format ('Recovered relation: 0 =')

    do i = 1, n
      if (r(i) .ne. 0.d0) then
        call mpfform (r(i), 64, 0, chr1)
        write (6, '(''+'',64a1,'' * '',a)') (chr1(j), j = 1, 64), &
          nam(i)(1:lnm(i))
      endif
    enddo

!   Check if original relation was recovered.

    if (kq .eq. 1) then
      d1 = 0.d0
      d2 = 0.d0

      do i = 1, n
        d1 = d1 + abs (dble (r(i)) - r1(i))
        d2 = d2 + abs (dble (r(i)) + r1(i))
      enddo

      if (d1 .eq. 0.d0 .or. d2 .eq. 0.d0) then
        kcs = kcs + 1
        write (6, 5)
5       format ('Original relation recovered.')
      else
        kps = kps + 1
      endif
    endif
  endif
  write (6, 6) tm1 - tm0
6 format ('CPU Time =',f12.4)
enddo

if (itr .gt. 1) then
  write (6, 7) kps, kcs
7 format (/'No. partial successes =',i5/'No. complete successes =',i5)
  kss = kps + kcs
  if (kss .ne. 0) then
    tm = tm / kss
    write (6, 8) tm
8   format ('Ave. CPU time of PS or CS runs =',f10.4)
  endif
endif
stop
end

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

!   This code performs the three-level, standard PSLQ algorithm.
!   David H. Bailey     2004-06-10

subroutine pslq3 (idb, gam, n, rb, x, is0, s1, s2, s3, iq, r)

!   This routine allocates the scratch space arrays is0, s1 and s2.  Handling
!   scratch space in this manner is not really necessary in Fortran-90, but
!   this design facilitates straightforward translation to Fortran-77.

!   Arguments are as follows:
!     idb = Debug flag: 0 (none) to 4 (full).
!     gam = PSLQ gamma parameter, normally set to sqrt(4/3).
!     n   = Dimension of input vector.
!     rb  = Log10 of maximum Euclidean norm of acceptable relation (type DP).
!     x   = Input real vector (type mp_real).
!     is0 = Scratch array (type integer -- see size below).
!     s1  = Scratch array (type double precision -- see size below).
!     s2  = Scratch array (type mp_realm -- see size below).
!     s3  = Scratch array (type mpreal -- see size below).
!     iq  = Output flag: 0 (unsuccessful) or 1 (successful).
!     r   = Output integer coefficient vector (type mp_real).

use mpmodule
use mpmodulem
implicit none
integer idb, iq, n
double precision gam, rb
integer is0(n)
double precision s1(6*n*n+3*n)
type (mp_realm) s2(3*n*n+2*n)
type (mp_real) s3(2*n*n+2*n), x(n), r(n)

call pslq3x (idb, gam, n, rb, x, is0(1), s1(1), s1(n*n+1), s1(2*n*n+1), &
  s1(3*n*n+1), s1(4*n*n+1), s1(5*n*n+1), s1(6*n*n+1), s1(6*n*n+n+1), &
  s1(6*n*n+2*n+1), s2(1), s2(n*n+1), s2(2*n*n+1), s2(3*n*n+1), &
  s2(3*n*n+n+1), s3(1), s3(n*n+1), s3(2*n*n+1), s3(2*n*n+n+1), iq, r)
return
end

subroutine pslq3x (idb, gam, n, rb, x, ix, da, db, dh, dsa, dsb, dsh, &
  dx, dy, dsy, wa, wb, wh, wt, wy, b, h, t, y, iq, r)

!   The following parameters are set in this routine:
!     ipi = Iteration print interval when idb >= 2.
!     ipm = Iteration check interval for MPM iterations.
!     itm = Maximum iteration count.  Run is aborted when this is exceeded.
!     nrs = Restart flag  0: no restart; 1: start from scratch, write restart
!           file; 2: read restart file, write restart file.

use mpmodule
use mpmodulem
implicit none
integer i, idb, ipi, ipm, iq, it, itm, its, izd, izm, izmm, j, j1, n, n1, &
  n2, n3, n4, nrs, nws
parameter (ipi = 1000, ipm = 10, itm = 10000000, nrs = 0)
double precision d1, d2, d3, d4, dplog10m, gam, rb, rn, second, &
  tm0, tm1, times(6)
integer ix(n)
double precision da(n,n), db(n,n), dh(n,n), dsa(n,n), dsb(n,n), &
  dsh(n,n), dx(n), dy(n), dsy(n)
type (mp_real) b(n,n), h(n,n), t(n), r(n), x(n), y(n), t1, t2
type (mp_realm) wa(n,n), wb(n,n), wh(n,n), wt(n), wy(n), boundm, wn, w1, w2
external dplog10m, second, boundm

!   Initialize.

if (idb .ge. 2) write (6, 1) n
1 format ('PSLQ3 integer relation detection: n =',i5)
iq = 0
it = 0
wn = 0.d0

if (idb .ge. 2) write (6, 2) it
2 format ('Iteration',i7,3x,'MP initialization')
if (nrs .ge. 1) open (12, file = 'pslq3.rst', form = 'unformatted')
if (nrs .le. 1) then
  do i = 1, 16
    times(i) = 0.d0
  enddo

  tm0 = second ()
  call initmp (idb, n, ix, dx, b, h, t, x, y, izm)
  tm1 = second ()
  times(1) = tm1 - tm0
  if (izm .ne. 0) goto 150
else
  rewind 12
  read (12) it
  read (12) times
  read (12) y
  read (12) b
  read (12) h
  rewind 12
endif

100 continue

!   Initialize MPM arrays from MP arrays.

if (idb .ge. 3) write (6, 3) it
3 format ('Iteration',i7,3x,'MPM initialization')
tm0 = second ()
call initmpm (idb, it, n, ix, dx, wa, wb, wh, wy, h, y, izmm)
tm1 = second ()
times(2) = times(2) + (tm1 - tm0)
if (izmm .ne. 0) goto 160

110 continue

!   Initialize DP arrays from MPM arrays.

if (idb .ge. 3) write (6, 4) it
4 format ('Iteration',i7,3x,'Start DP iterations')
call initdp (idb, it, n, da, db, dh, dy, wh, wy, izd)
call savedp (n, da, db, dh, dy, dsa, dsb, dsh, dsy)
its = it

if (izd .eq. 0) then

!   Perform an LQ decomposition on DH, prior to DP iterations.

  call lqdp (n, n - 1, dh)

!   Perform DP iterations.

120 continue

  it = it + 1
  if (idb .ge. 4 .or. idb .ge. 2 .and. mod (it, ipi) .eq. 0) write (6, 5) it
5 format ('Iteration',i7)
  tm0 = second ()
  call iterdp (idb, gam, it, n, ix, da, db, dh, dy, izd)
  tm1 = second ()
  times(3) = times(3) + (tm1 - tm0)

  if (izd .eq. 0) then
    if (mod (it - its, ipm) .eq. 0) then
      call savedp (n, da, db, dh, dy, dsa, dsb, dsh, dsy)
      its = it
    endif
    goto 120
  else

    if (izd .eq. 2) then

!   DP iteration was aborted -- revert to previous data.

      it = its
      call savedp (n, dsa, dsb, dsh, dsy, da, db, dh, dy)
    endif

!   Update the MPM arrays from the DP arrays.

    tm0 = second ()
    if (idb .ge. 3) write (6, 6) it
6   format ('Iteration',i7,3x,'MPM update')
    call updtmpm (idb, it, n, ix, dx, da, db, wa, wb, wh, wt, wy, izmm)
    tm1 = second ()
    times(4) = times(4) + (tm1 - tm0)

    if (izmm .eq. 0) then
      if (izd .eq. 2) then
        goto 130
      else
        goto 110
      endif
    elseif (izmm .eq. 1) then

!   Update the MP arrays from the MPM arrays.

      if (idb .ge. 2) write (6, 7) it
7     format ('Iteration',i7,3x,'MP update')
      tm0 = second ()
      call updtmp (idb, it, n, ix, dx, wa, wb, b, h, t, y, izm)
      tm1 = second ()
      times(5) = times(5) + (tm1 - tm0)

      if (nrs .ge. 1) then
        rewind 12
        write (12) it
        write (12) times
        write (12) y
        write (12) b
        write (12) h
        rewind 12
      endif

!   Compute norm bound.

      call lqmpm (n, n - 1, wh)
      w1 = boundm (n, wh)
      call decmdm (w1, d3, n3)
      wn = max (wn, w1)
      call decmdm (wn, d4, n4)
      if (idb .ge. 2) then
        write (6, 8) it, d3, n3, d4, n4
8       format ('Iteration',i7,3x,'Norm bound =',f11.6,'D',i5,3x, &
          'Max. bound =',f11.6,'D',i5)
      endif
      if (it .gt. itm) then
        if (idb .ge. 1) write (6, 9) itm
9       format ('Iteration limit exceeded',i7)
        goto 160
      endif
      d3 = log10 (d3) + n3 * log10 (2.d0)
      if (d3 .gt. rb) then
        if (idb .ge. 1) write (6, 10) rb
10      format ('Norm bound limit exceeded.',1p,d15.6)
        goto 160
      endif
      if (izm .eq. 0) then
        if (izd .eq. 2) then
          goto 130
        else
          goto 100
        endif
      elseif (izm .eq. 1) then
        goto  150
      elseif (izm .eq. 2) then
        goto 160
      endif
    elseif (izmm .eq. 2) then
      goto 160
    endif
  endif
endif

130 continue

!   Perform an LQ decomposition on wh, prior to MPM iterations.

if (idb .ge. 2) write (6, 11) it
11 format ('Iteration',i7,3x,'Start MPM iterations')
tm0 = second ()
call lqmpm (n, n - 1, wh)
tm1 = second ()
times(2) = times(2) + (tm1 - tm0)

!   Perform MPM iterations.

140 continue

it = it + 1
if (idb .ge. 2) write (6, 12) it
12 format ('Iteration',i7)
tm0 = second ()
call itermpm (idb, gam, it, n, ix, dx, wa, wb, wh, wy, izmm)
tm1 = second ()
times(6) = times(6) + (tm1 - tm0)

if (izmm .eq. 0) then
  if (mod (it - its, ipm) .eq. 0) then

!   Check to see if DP iterations can be resumed.

    call checkm (idb, it, n, wh, wy, izd)
    if (izd .eq. 0) then
      if (idb .ge. 2) write (6, 13) it
13    format ('Iteration',i7,3x,'Return to DP iterations')
      goto 110
    endif
  endif
  goto 140
elseif (izmm .eq. 1) then

!   Update the MP arrays from the MPM arrays.

  if (idb .ge. 2) write (6, 14) it
14 format ('Iteration',i7,3x,'MP update')
  tm0 = second ()
  call updtmp (idb, it, n, ix, dx, wa, wb, b, h, t, y, izm)
  tm1 = second ()
  times(5) = times(5) + (tm1 - tm0)
  if (izm .eq. 0) then
    goto 100
  elseif (izm .eq. 1) then
    goto 150
  elseif (izm .eq. 2) then
    goto 160
  endif
elseif (izmm .eq. 2) then
  goto 160
endif

!   A relation has been detected.  Output the final norm bound and other info.

150 continue

tm0 = second ()
t1 = 1.d300
t2 = 0.d0

!   Select the relation corresponding to the smallest y entry and compute norm.

do j = 1, n
  if (abs (y(j)) < t1) then
    j1 = j
    t1 = abs (y(j))
  endif
  t2 = max (t2, abs (y(j)))
enddo

do i = 1, n
  r(i) = b(i,j1)
enddo

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)
w1 = 0.d0

do i = 1, n
  w1 = w1 + mprealm (r(i)) ** 2
enddo

w1 = sqrt (w1)
call mpsetprecwords (nws)
call decmdm (w1, d3, n3)

!   Output the final norm bound and other info.

if (idb .ge. 1) then
  call lqmpm (n, n - 1, wh)
  w2 = boundm (n, wh)
  wn = max (wn, w2)
  call decmd (t1, d1, n1)
  call decmd (t2, d2, n2)
  call decmdm (wn, d4, n4)
  write (6, 15) it, d1, n1, d2, n2, d4, n4
15 format ('Iteration',i7,3x,'Relation detected'/ &
  'Min, max of y =',f11.6,'D',i6,f11.6,'D',i6/'Max. bound =',f11.6,'D',i6)
  write (6, 16) j1, d3, n3, d1, n1
16 format ('Index of relation =',i4,3x,'Norm =',f11.5,'D',i5,3x, &
  'Residual =',f11.6,'D',i6)
endif

if (dplog10m (w1) .le. rb) then
  iq = 1
else
  if (idb .ge. 2) write (6, 17)
17 format ('Relation is too large.')
endif

160 continue

if (idb .ge. 2) write (6, 18) times
18 format ('CPU times:'/(5f12.2))

return
end

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

!   First-level subroutines.

subroutine checkm (idb, it, n, wh, wy, izd)

!   Checks wh and wy to see if DP iterations can be resumed.

use mpmodulem
implicit none
integer i, idb, it, izd, n, n1, nws
double precision d1, deps
parameter (deps = 1d-10)
type (mp_realm) wh(n,n), wy(n), t1, t2, t3, t4

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)
izd = 0
t1 = 1.d300
t2 = 0.d0

!   Find the min and max absolute value in the wy vector.

do i = 1, n
  t1 = min (t1, abs (wy(i)))
  t2 = max (t2, abs (wy(i)))
enddo

t3 = t1 / t2
t4 = deps
if (t3 .lt. t4) then
  if (idb .ge. 2) then
    call decmdm (t3, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i7,3x,'checkm: Small min/max ratio in wy =',f11.6, &
    'D',i4)
  endif
  izd = 1
endif

call mpsetprecwords (nws)
return
end

subroutine initdp (idb, it, n, da, db, dh, dy, wh, wy, izd)

!   This re-initializes the DP arrays from the MPM arrays.

use mpmodulem
implicit none
integer i, idb, it, izd, j, n, n1, nws
double precision da(n,n), db(n,n), dh(n,n), dy(n), d1, deps
type (mp_realm) wh(n,n), wy(n), t1, t2, t3, t4
parameter (deps = 1d-10)

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)
izd = 0
t1 = 1.d300
t2 = 0.d0

!   Find the min and max absolute value in the wy vector.

do i = 1, n
  t1 = min (t1, abs (wy(i)))
  t2 = max (t2, abs (wy(i)))
enddo

!   If the dynamic range of the wy vector is too great, set the izd flag and
!   abort this initialization.

t3 = t1 / t2
t4 = deps
if (t3 .lt. t4) then
  if (idb .ge. 3) then
    call decmdm (t3, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i7,3x,'initdp: Small min/max ratio in wy =',f11.6, &
    'D',i4)
  endif
  izd = 1
  goto 100
endif

!   Set dy to be the scaled wy vector.

t1 = 1.d0 / t2

do i = 1, n
  dy(i) = t1 * wy(i)
enddo

!   Find the maximum absolute value of the wh matrix diagonals.

t2 = 0.d0

do j = 1, n - 1
  t2 = max (t2, abs (wh(j,j)))
enddo

!   Set dh to be the scaled wh matrix.

t1 = 1.d0 / t2

do j = 1, n - 1
  do i = 1, n
    dh(i,j) = t1 * wh(i,j)
  enddo
enddo

!   Set da and db to the identity.

do j = 1, n
  do i = 1, n
    da(i,j) = 0.d0
    db(i,j) = 0.d0
  enddo

  da(j,j) = 1.d0
  db(j,j) = 1.d0
enddo

if (idb .ge. 4) then
  write (6, 2)
2 format ('initdp: Scaled dy vector:')
  call matoutdp (1, n, dy)
  write (6, 3)
3 format ('initdp: Scaled dh matrix:')
  call matoutdp (n, n - 1, dh)
endif

100 continue

call mpsetprecwords (nws)
return
end

subroutine initmp (idb, n, ix, dx, b, h, s, x, y, izm)

!   This initializes MP arrays at the beginning.

use mpmodule
implicit none
integer i, idb, izm, j, k, n, n1
double precision d1
integer ix(n)
double precision dx(n)
type (mp_real) b(n,n), h(n,n), s(n), x(n), y(n), t1

if (idb .ge. 4) then
  write (6, 1)
1 format ('initmp: Input x vector:')
  call matoutmd (1, n, ix, dx, x)
endif
izm = 0

!   Set b to the identity matrix.

do j = 1, n
  do i = 1, n
    b(i,j) = 0.d0
  enddo

  b(j,j) = 1.d0
enddo

t1 = 0.d0

!   Compute the x vector, the square root of the partial sum of squares of x,
!   and the y vector, which is the normalized x vector.

do i = n, 1, -1
  t1 = t1 + x(i) ** 2
  s(i) = sqrt (t1)
enddo

t1 = 1.d0 / s(1)

do i = 1, n
  y(i) = t1 * x(i)
  s(i) = t1 * s(i)
enddo

!   Compute the initial h matrix.

do j = 1, n - 1
  do i = 1, j - 1
    h(i,j) = 0.d0
  enddo

  h(j,j) = s(j+1) / s(j)
  t1 = y(j) / (s(j) * s(j+1))

  do i = j + 1, n
    h(i,j) = - y(i) * t1
  enddo
enddo

!  Perform reduction on h, updating y, b and h.

do i = 2, n
  do j = i - 1, 1, -1
    t1 = anint (h(i,j) / h(j,j))
    if (t1 .ne. 0.d0) then
      y(j) = y(j) + t1 * y(i)

      do k = i, n
        b(k,j) = b(k,j) + t1 * b(k,i)
      enddo

      do k = 1, j
        h(i,k) = h(i,k) - t1 * h(j,k)
      enddo
    endif
  enddo
enddo

t1 = 1.d300

do i = 1, n
  t1 = min (t1, abs (y(i)))
enddo

if (t1 .le. mpeps) then
  if (idb .ge. 2) then
    call decmd (t1, d1, n1)
    write (6, 2) 0, d1, n1
2   format ('Iteration',i8,3x,'initmp: Small value in y =',f11.6,'D',i5)
  endif
  izm = 1
endif

if (idb .ge. 4) then
  write (6, 3)
3 format ('initmp: Initial y vector:')
  call matoutmd (1, n, ix, dx, y)
  write (6, 4)
4 format ('initmp: Initial h matrix:')
  call matoutmd (n, n - 1, ix, dx, h)
endif

return
end

subroutine initmpm (idb, it, n, ix, dx, wa, wb, wh, wy, h, y, izmm)

!   This re-initializes the MPM arrays from the MP arrays.

use mpmodule
use mpmodulem
implicit none
integer i, idb, it, izmm, j, n, n1, ntl, nws
parameter (ntl = 72)
double precision d1
integer ix(n)
double precision dx(n)
type (mp_realm) wa(n,n), wb(n,n), wh(n,n), wy(n), t1, t2, t3, teps
type (mp_real) h(n,n), y(n)

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)
teps = mprealm (2.d0) ** (ntl - mpwdsm * mpnbt)
izmm = 0
t1 = 1.d300
t2 = 0.d0

!   Find the min and max absolute value in the y vector.

do i = 1, n
  t3 = abs (mprealm (y(i)))
  t1 = min (t1, t3)
  t2 = max (t2, t3)
enddo

!   If the dynamic range of the y vector is goo great, then abort.

t3 = t1 / t2
if (t3 .lt. teps) then
  if (idb .ge. 2) then
    call decmd (t3, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i7,3x,'initmpm: Small min/max ratio in y =',f11.6, &
    'D',i4/ 'Run aborted.')
  endif
  izmm = 1
  goto 100
endif

!   Set wy to the scaled y vector.

t1 = 1.d0 / t2

do i = 1, n
  wy(i) = t1 * mprealm (y(i))
enddo

!   Set wh to h.

do j = 1, n - 1
  do i = 1, n
    wh(i,j) = h(i,j)
  enddo
enddo

!   Set wa and wb to the identity.

do j = 1, n
  do i = 1, n
    wa(i,j) = 0.d0
    wb(i,j) = 0.d0
  enddo

  wa(j,j) = 1.d0
  wb(j,j) = 1.d0
enddo

if (idb .ge. 4) then
  write (6, 2)
2 format ('initmpm: wy vector:')
  call matoutmdm (1, n, ix, dx, wy)
  write (6, 3)
3 format ('initmpm: Factored wh matrix:')
  call matoutmdm (n, n - 1, ix, dx, wh)
endif

100 continue

call mpsetprecwords (nws)
return
end

subroutine iterdp (idb, gam, it, n, ix, da, db, dh, dy, izd)

!   This performs one iteration of the PSLQ algorithm using DP arithmetic.

implicit none
integer i, idb, im, im1, it, izd, j, j1, k, n, n1
double precision deps, gam, t1, t2, t3, t4, tmx1, tmx2
integer ix(n)
double precision da(n,n), db(n,n), dh(n,n), dy(n)
parameter (tmx1 = 1.d13, tmx2 = 2.d0**52, deps = 1.d-14)

izd = 0
t1 = 0.d0

!   Find  im = i  such that  gam^i * |dh(i,i)|  is maximized.

do i = 1, n - 1
  t2 = gam ** i * abs (dh(i,i))
  if (t2 .gt. t1) then
    im = i
    t1 = t2
  endif
enddo

im1 = im + 1

! Exchange the im and im+1 entries of dy, rows of da and dh, and columns of db.

t1 = dy(im)
dy(im) = dy(im1)
dy(im1) = t1

do i = 1, n
  t1 = da(im,i)
  da(im,i) = da(im1,i)
  da(im1,i) = t1
  t1 = db(i,im)
  db(i,im) = db(i,im1)
  db(i,im1) = t1
enddo

do i = 1, n - 1
  t1 = dh(im,i)
  dh(im,i) = dh(im1,i)
  dh(im1,i) = t1
enddo

!  Update dh with permutation produced above.

if (im .le. n - 2) then
  t1 = dh(im,im)
  t2 = dh(im,im1)
  t3 = sqrt (t1 ** 2 + t2 ** 2)
  t1 = t1 / t3
  t2 = t2 / t3

  do i = im, n
    t3 = dh(i,im)
    t4 = dh(i,im1)
    dh(i,im) = t1 * t3 + t2 * t4
    dh(i,im1) = - t2 * t3 + t1 * t4
  enddo
endif

t2 = 0.d0

!  Perform reduction on dh, updating dy, da, db and dh.

do i = im1, n
  j1 = min (i - 1, im1)

  do j = j1, 1, -1
    t1 = anint (dh(i,j) / dh(j,j))
    if (t1 .ne. 0.d0) then
      dy(j) = dy(j) + t1 * dy(i)

      do k = 1, n
        da(i,k) = da(i,k) - t1 * da(j,k)
        db(k,j) = db(k,j) + t1 * db(k,i)
        t2 = max (t2, abs (da(i,k)), abs (db(k,j)))
      enddo

      do k = 1, j
        dh(i,k) = dh(i,k) - t1 * dh(j,k)
      enddo
    endif
  enddo
enddo

!   Find the min absolute value entry of dy.

t1 = 1d300

do i = 1, n
  t1 = min (t1, abs (dy(i)))
enddo

if (t1 .le. deps) then
  if (idb .ge. 3) write (6, 1) it, t1
1 format ('Iteration',i7,3x,'iterdp: Small value in dy =',1pd15.6)
  izd = 1
endif

if (t2 .gt. tmx1 .and. t2 .le. tmx2) then
  if (idb .ge. 3) write (6, 2) it, t2
2 format ('Iteration',i7,3x,'iterdp: Large value in da or db =',1pd15.6)
  izd = 1
elseif (t2 .gt. tmx2) then
  if (idb .ge. 2) write (6, 3) it, t2
3 format ('Iteration',i7,3x,'iterdp: Very large value in da or db =',1pd15.6)
  izd = 2
  return
endif

if (idb .ge. 4) then
  write (6, 5)
5 format ('iterdp: Updated dy:')
  call matoutdp (1, n, dy)
  write (6, 6)
6 format ('iterdp: Updated da matrix:')
  call matoutdp (n, n, da)
  write (6, 7)
7 format ('iterdp: Updated db matrix:')
  call matoutdp (n, n, db)
  write (6, 8)
8 format ('iterdp: Updated dh matrix:')
  call matoutdp (n, n - 1, dh)
endif

return
end

subroutine itermpm (idb, gam, it, n, ix, dx, wa, wb, wh, wy, izmm)

!   This performs one iteration of the PSLQ algorithm using MPM arithmetic.

use mpmodulem
implicit none
integer i, idb, im, im1, it, izmm, j, j1, k, n, n1, ntl, nws
parameter (ntl = 72)
double precision d1, d2, gam
type (mp_realm) t1, t2, t3, t4, teps, tmx1, tmx2
integer ix(n)
double precision dx(n)
type (mp_realm) wa(n,n), wb(n,n), wh(n,n), wy(n)

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)
teps = mprealm (2.d0) ** (ntl - mpwdsm * mpnbt)
tmx1 = mprealm (2.d0) ** (mpwdsm * mpnbt - ntl)
tmx2 = mprealm (2.d0) ** (mpwdsm * mpnbt)
izmm = 0
t1 = 0.d0

!   Find  im = i  such that  gam^i * |wh(i,i)|  is maximized.

do i = 1, n - 1
  t2 = gam ** i * abs (wh(i,i))
  if (t2 .gt. t1) then
    im = i
    t1 = t2
  endif
enddo

im1 = im + 1

! Exchange the im and im+1 entries of wy, rows of wa and wh, and columns of wb.

t1 = wy(im)
wy(im) = wy(im1)
wy(im1) = t1

do i = 1, n
  t1 = wa(im,i)
  wa(im,i) = wa(im1,i)
  wa(im1,i) = t1
  t1 = wb(i,im)
  wb(i,im) = wb(i,im1)
  wb(i,im1) = t1
enddo

do i = 1, n - 1
  t1 = wh(im,i)
  wh(im,i) = wh(im1,i)
  wh(im1,i) = t1
enddo

!  Update wh with permutation produced above.

if (im .le. n - 2) then
  t1 = wh(im,im)
  t2 = wh(im,im1)
  t3 = sqrt (t1 ** 2 + t2 ** 2)
  t1 = t1 / t3
  t2 = t2 / t3

  do i = im, n
    t3 = wh(i,im)
    t4 = wh(i,im1)
    wh(i,im) = t1 * t3 + t2 * t4
    wh(i,im1) = - t2 * t3 + t1 * t4
  enddo
endif

t2 = 0.d0
t3 = 0.d0

!  Perform reduction on wh, updating wy, wa, wb and wh.

do i = im1, n
  j1 = min (i - 1, im1)

  do j = j1, 1, -1
    t1 = anint (wh(i,j) / wh(j,j))
    if (t1 .ne. t3) then
      wy(j) = wy(j) + t1 * wy(i)

      do k = 1, n
        wa(i,k) = wa(i,k) - t1 * wa(j,k)
        wb(k,j) = wb(k,j) + t1 * wb(k,i)
        t2 = max (t2, abs (wa(i,k)), abs (wb(k,j)))
      enddo

      do k = 1, j
        wh(i,k) = wh(i,k) - t1 * wh(j,k)
      enddo
    endif
  enddo
enddo

!   Find the min of wy.

t1 = 1d300

do i = 1, n
  t1 = min (t1, abs (wy(i)))
enddo

if (t1 .le. teps) then
  if (idb .ge. 2) then
    call decmdm (t1, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i7,3x,'itermpm: Small value in wy =',f11.6,'D',i4)
  endif
  izmm = 1
endif

if (t2 .gt. tmx1 .and. t2 .le. tmx2) then
  if (idb .ge. 2) then
    call decmdm (t2, d1, n1)
    write (6, 2) it, d1, n1
2   format ('Iteration',i7,3x,'itermpm: Large value in wa or wb =', &
      f11.6,'D',i4)
  endif
  izmm = 1
elseif (t2 .gt. tmx2) then
  if (idb .ge. 1) then
    call decmdm (t2, d1, n1)
    write (6, 3) it, d1, n1
3   format ('itermpm: Very large value in wa or wb =',f11.6,'D',i4/ &
      'Run aborted.')
  endif
  izmm = 2
  goto 100
endif

if (idb .ge. 4) then
  write (6, 5)
5 format ('itermpw: Updated wy:')
  call matoutmdm (1, n, ix, dx, wy)
  write (6, 6)
6 format ('itermpw: Updated wa matrix:')
  call matoutmdm (n, n, ix, dx, wa)
  write (6, 7)
7 format ('itermpw: Updated wb matrix:')
  call matoutmdm (n, n, ix, dx, wb)
  write (6, 8)
8 format ('itermpw: Updated wh matrix:')
  call matoutmdm (n, n - 1, ix, dx, wh)
endif

100 continue

call mpsetprecwords (nws)
return
end

subroutine lqdp (n, m, dh)

!   This performs an LQ decomposition on the DP matrix dh.  It is a simplified
!   and transposed adaptation of the subroutine dqrdc from Linpack.

implicit none
integer i, j, jp, l, lup, m, ml, n
double precision dh(n,m), nrmxl, one, t, zero

zero = 0.d0
one = 1.d0
lup = min (m,n)

!   Perform the householder reduction of dh.

do l = 1, lup
  if (l .eq. m) go to 280

!   Compute the householder transformation for column l.

  ml = m - l
  t = zero

  do i = 0, ml
    t = t + dh(l,l+i) ** 2
  enddo

  nrmxl = sqrt (t)
  if (nrmxl .eq. zero) go to 270
  if (dh(l,l) .ne. zero) nrmxl = sign (nrmxl, dh(l,l))
  t = one / nrmxl

  do i = 0, ml
    dh(l,l+i) = t * dh(l,l+i)
  enddo

  dh(l,l) = one + dh(l,l)

!   Apply the transformation to the remaining columns, updating the norms.

  do j = l + 1, n
    t = zero

    do i = 0, ml
      t = t + dh(l,l+i) * dh(j,l+i)
    enddo

    t = - t / dh(l,l)

    do i = 0, ml
      dh(j,l+i) = dh(j,l+i) + t * dh(l,l+i)
    enddo
  enddo

!   Save the transformation.

  dh(l,l) = - nrmxl
270 continue
280 continue
enddo

!   Zero dh above the diagonal.

do j = 1, m
  do i = 1, j - 1
    dh(i,j) = 0.d0
  enddo
enddo

return
end

subroutine lqmpm (n, m, h)

!   This performs an LQ decomposition on the MPM matrix h.  It is a simplified
!   and transposed adaptation of the subroutine dqrdc from Linpack.

use mpmodulem
implicit none
integer i, j, jp, l, lup, m, ml, n, nws
type (mp_realm) h(n,m), nrmxl, one, t, zero

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)
zero = 0.d0
one = 1.d0
lup = min (m,n)

!   Perform the householder reduction of h.

do l = 1, lup
  if (l .eq. m) go to 280

!   Compute the householder transformation for column l.

  ml = m - l
  t = zero

  do i = 0, ml
    t = t + h(l,l+i) ** 2
  enddo

  nrmxl = sqrt (t)
  if (nrmxl .eq. zero) go to 270
  if (h(l,l) .ne. zero) nrmxl = sign (nrmxl, h(l,l))
  t = one / nrmxl

  do i = 0, ml
    h(l,l+i) = t * h(l,l+i)
  enddo

  h(l,l) = one + h(l,l)

!   Apply the transformation to the remaining columns, updating the norms.

  do j = l + 1, n
    t = zero

    do i = 0, ml
      t = t + h(l,l+i) * h(j,l+i)
    enddo

    t = - t / h(l,l)

    do i = 0, ml
      h(j,l+i) = h(j,l+i) + t * h(l,l+i)
    enddo
  enddo

!   Save the transformation.

  h(l,l) = - nrmxl
270 continue
280 continue
enddo

!   Zero h above the diagonal.

do j = 1, m
  do i = 1, j - 1
    h(i,j) = 0.d0
  enddo
enddo

call mpsetprecwords (nws)
return
end

subroutine savedp (n, da, db, dh, dy, dsa, dsb, dsh, dsy)

!   This saves the arrays dy, da, db, dh in case dp iterations must be aborted.
!   A call to the same routine, with (da,db,dh,dy) and (dsa,dsb,dsh,dsy)
!   exchanged, serves to restore these arrays.

implicit none
integer i, j, n
double precision da(n,n), db(n,n), dh(n,n), dy(n), dsa(n,n), dsb(n,n), &
  dsh(n,n), dsy(n)

do i = 1, n
  dsy(i) = dy(i)
enddo

do j = 1, n
  do i = 1, n
    dsa(i,j) = da(i,j)
    dsb(i,j) = db(i,j)
  enddo
enddo

do j = 1, n - 1
  do i = 1, n
    dsh(i,j) = dh(i,j)
  enddo
enddo

return
end

subroutine updtmp (idb, it, n, ix, dx, wa, wb, b, h, t, y, izm)

!   This update the MP arrays from the MPM arrays.

use mpmodule
use mpmodulem
implicit none
integer i, i1, idb, it, izm, j, n, n1, n2, ntl
parameter (ntl = 72)
double precision d1, d2
type (mp_real) t1, t2, teps
integer ix(n)
double precision dx(n)
type (mp_realm) wa(n,n), wb(n,n)
type (mp_real) b(n,n), h(n,n), t(n), y(n)

teps = 2.d0 ** ntl * mpeps
izm = 0
t1 = 1.d300
t2 = 0.d0

!   Update y with wb.

call mxmm2 (1, n, y, wb, t)

do i = 1, n
  if (abs (y(i)) < t1) then
    i1 = i
    t1 = abs (y(i))
  endif
  t2 = max (t2, abs (y(i)))
enddo

if (idb .ge. 2) then
  call decmd (t1, d1, n1)
  call decmd (t2, d2, n2)
  write (6, 1) it, d1, n1, d2, n2
1 format ('Iteration',i7,3x,'updtmp: Min, max of y =',f11.6,'D',i6, &
    f11.6,'D',i6)
endif

!   Update b with wb.

call mxmm2 (n, n, b, wb, t)

!   Update h with wa.

call mxmm1 (n, n - 1, wa, h, t)

!   Find the largest entry of b in the same row as the smallest y.

t2 = 0.d0

do i = 1, n
  t2 = max (t2, abs (b(i,i1)))
enddo

if (t1 .le. t2 * teps) then
  if (idb .ge. 2) then
    call decmd (t1, d1, n1)
    write (6, 2) it, d1, n1
2   format ('Iteration',i7,3x,'updtmp: Small value in y =',f11.6,'D',i6)
  endif
  if (t1 .le. t2 * mpeps) then
    izm = 1
  else
    if (idb .ge. 1) write (6, 3) it
3   format ('Iteration',i7,3x,'updtmp: Precision exhausted.')
    izm = 2
  endif
endif

if (idb .ge. 4) then
  write (6, 5)
5 format ('updtmp: Updated y:')
  call matoutmd (1, n, ix, dx, y)
  write (6, 6)
6 format ('updtmp: Updated b matrix:')
  call matoutmd (n, n, ix, dx, b)
  write (6, 7)
7 format ('updtmp: Updated h matrix:')
  call matoutmd (n, n - 1, ix, dx, h)
endif

return
end

subroutine updtmpm (idb, it, n, ix, dx, da, db, wa, wb, wh, wt, wy, izmm)

!   This updates the MPM arrays from the DP arrays.

use mpmodulem
implicit none
integer i, idb, it, izmm, j, n, n1, n2, ntl, nws
parameter (ntl = 72)
double precision d1, d2
type (mp_realm) t1, t2, teps, tmx1, tmx2
integer ix(n)
double precision da(n,n), db(n,n), dx(n)
type (mp_realm) wa(n,n), wb(n,n), wh(n,n), wt(n), wy(n)

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)
teps = mprealm (2.d0) ** (ntl - mpwdsm * mpnbt)
tmx1 = mprealm (2.d0) ** (mpwdsm * mpnbt - ntl)
tmx2 = mprealm (2.d0) ** (mpwdsm * mpnbt)
izmm = 0
t1 = 1.d300
t2 = 0.d0

!   Update wy with db.

call mxmdm2 (1, n, wy, db, wt)

do i = 1, n
  t1 = min (t1, abs (wy(i)))
  t2 = max (t2, abs (wy(i)))
enddo

if (idb .ge. 3) then
  call decmdm (t1, d1, n1)
  call decmdm (t2, d2, n2)
  write (6, 1) it, d1, n1, d2, n2
1 format ('Iteration',i7,3x,'updtmpw: Min, max of wy =',f11.6,'D',i4, &
     f11.6,'D',i4)
endif
if (t1 .le. teps) then
  if (idb .ge. 2) then
    call decmdm (t1, d1, n1)
    write (6, 2) it, d1, n1
2   format ('Iteration',i7,3x,'updtmpw: Small value in wy =',f11.6,'D',i4)
  endif
  izmm = 1
endif

!   Update wa with da.

call mxmdm1 (n, n, da, wa, wt)

!   Update wb with db.

call mxmdm2 (n, n, wb, db, wt)
t2 = 0.d0

do j = 1, n
  do i = 1, n
    t2 = max (t2, abs (wa(i,j)), abs (wb(i,j)))
  enddo
enddo

if (t2 .gt. tmx1 .and. t2 .le. tmx2) then
  if (idb .ge. 2) then
    call decmdm (t2, d1, n1)
    write (6, 3) it, d1, n1
3   format ('Iteration',i7,3x,'updtmpm: Large value in wa or wb =', &
      f11.6,'D',i4)
  endif
  izmm = 1
elseif (t2 .gt. tmx2) then
  if (idb .ge. 1) then
    call decmdm (t2, d1, n1)
    write (6, 4) it, d1, n1
4   format ('updtmpm: Very large value in wa or wb =',f11.6,'D',i4/ &
      'Run aborted.')
  endif
  izmm = 2
  goto 100
endif

!   Update wh with da.

call mxmdm1 (n, n - 1, da, wh, wt)

if (idb .ge. 4) then
  write (6, 6)
6 format ('updtmpw: Updated wy:')
  call matoutmdm (1, n, ix, dx, wy)
  write (6, 7)
7 format ('updtmpw: Updated wa matrix:')
  call matoutmdm (n, n, ix, dx, wa)
  write (6, 8)
8 format ('updtmpw: Updated wb matrix:')
  call matoutmdm (n, n, ix, dx, wb)
  write (6, 9)
9 format ('updtmpw: Updated wh matrix:')
  call matoutmdm (n, n - 1, ix, dx, wh)
endif

100 continue

call mpsetprecwords (nws)
return
end

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

!   Second- and third-level subroutines.

function boundm (n, wh)

!   This computes the norm bound using MPM arithmetic, based on the array wh.

use mpmodulem
implicit none
integer i, n, nws
type (mp_realm) wh(n,n), boundm, t1

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)
t1 = 0.d0

do i = 1, n - 1
  t1 = max (t1, abs (wh(i,i)))
enddo

boundm = 1.d0 / t1
call mpsetprecwords (nws)
return
end

function dplog10m (a)

!   For input MPM value a, this routine returns a DP approximation to log10 (a).

use mpmodulem
implicit none
integer ia
double precision da, dplog10m, t1
type (mp_realm) a

call mpmdc (a%mpr, da, ia)
if (da .le. 0.d0) then
  dplog10m = -1d300
else
  dplog10m = log10 (abs (da)) + ia * log10 (2.d0)
endif

100 continue
return
end

subroutine decmd (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodule
implicit none
integer ia, ib
type (mp_real) a
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)

call mpmdc (a%mpr, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end

subroutine decmdm (a, b, ib)

!   For input MPM value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodulem
implicit none
integer ia, ib
type (mp_realm) a
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)

call mpmdc (a%mpr, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end

function drand ()

!   This routine returns a pseudorandom DP floating number nearly uniformly
!   distributed between 0 and 1 by means of a linear congruential scheme.
!   2^28 pseudorandom numbers with 30 bits each are returned before repeating.

implicit none
double precision drand, f7, r30, sd, t1, t2, t30
parameter (f7 = 78125.d0, r30 = 0.5d0 ** 30, t30 = 2.d0 ** 30)
save sd
data sd/314159265.d0/

t1 = f7 * sd
t2 = aint (r30 * t1)
sd = t1 - t30 * t2
drand = r30 * sd

return
end

subroutine matoutdp (n1, n2, a)

!   This outputs the DP matrix a.

implicit none
integer i, j, n1, n2
double precision a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)
  write (6, 2) (a(i,j), j = 1, n2)
2 format (1p5d15.5)
enddo

return
end

subroutine matoutmd (n1, n2, ix, dx, a)

!   This outputs the MP matrix a as a DP matrix.

use mpmodule
implicit none
integer i, j, n1, n2
integer ix(n2)
double precision dx(n2)
type (mp_real) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call decmd (a(i,j), dx(j), ix(j))
  enddo

  write (6, 2) (dx(j), ix(j), j = 1, n2)
2 format (4(f13.8,'D',i5))
enddo

return
end

subroutine matoutmp (n1, n2, a)

!   This outputs the MP matrix a.  It may be used in place of calls to matoutmd
!   in the code above if greater accuracy is desired in debug output.

use mpmodule
implicit none
integer i, j, n1, n2
type (mp_real) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call mpwrite (6, a(i,j))
  enddo
enddo

return
end

subroutine matoutmdm (n1, n2, ix, dx, a)

!   This outputs the MPM matrix a as a DP matrix.

use mpmodulem
implicit none
integer i, j, n1, n2
integer ix(n2)
double precision dx(n2)
type (mp_realm) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call decmdm (a(i,j), dx(j), ix(j))
  enddo

  write (6, 2) (dx(j), ix(j), j = 1, n2)
2 format (4(f13.8,'D',i5))
enddo

return
end

subroutine mxmdm1 (n1, n2, a, b, c)

!  This multiplies the DP square matrix a by the MPM matrix b, and the result
!  is placed in b.  c is a MPM scratch array with n1 cells.  n1, n2 are
!  the matrix dimensions as indicated below.

use mpmodulem
implicit none
integer i, j, n1, n2, nws
double precision a(n1,n1)
type (mp_realm) b(n1,n2), c(n1), t1, t2

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)

do j = 1, n2
  do i = 1, n1
    call mpdotdm (n1, 1, b(1,j), n1, a(i,1), t1)
    c(i) = t1
  enddo

  do i = 1, n1
    b(i,j) = c(i)
  enddo
enddo

call mpsetprecwords (nws)
return
end

subroutine mxmdm2 (n1, n2, a, b, c)

!  This multiplies the MPM matrix a by the DP square matrix b, and the result
!  is placed in a.  c is a MPM scratch array with n2 cells.  n1, n2 are
!  the matrix dimensions as indicated below.

use mpmodulem
implicit none
integer i, j, n1, n2, nws
double precision b(n2,n2)
type (mp_realm) a(n1,n2), c(n2), t1, t2

call mpgetprecwords (nws)
call mpsetprecwords (mpwdsm)

do i = 1, n1
  do j = 1, n2
    call mpdotdm (n2, n1, a(i,1), 1, b(1,j), t1)
    c(j) = t1
  enddo

  do j = 1, n2
    a(i,j) = c(j)
  enddo
enddo

call mpsetprecwords (nws)
return
end

subroutine mxmm1 (n1, n2, a, b, c)

!  This multiplies the MPM square matrix a by the MP matrix b, and the result
!  is placed in b.  c is a MP scratch array with n1 cells.  n1, n2 are
!  the matrix dimensions as indicated below.

use mpmodule
use mpmodulem
implicit none
integer i, j, k, mw4, n1, n2
type (mp_realm) a(n1,n1)
type (mp_real) b(n1,n2), c(n1), t1, t2

do j = 1, n2
  do i = 1, n1
    t1 = 0.d0

    do k = 1, n1
      t1 = t1 + a(i,k) * b(k,j)
    enddo

    c(i) = t1
  enddo

  do i = 1, n1
    b(i,j) = c(i)
  enddo
enddo

return
end

subroutine mxmm2 (n1, n2, a, b, c)

!  This multiplies the MP matrix a by the MPM square matrix b, and the result
!  is placed in a.  c is a MP scratch array with n2 cells.  n1, n2 are
!  the matrix dimensions as indicated below.

use mpmodule
use mpmodulem
implicit none
integer i, j, k, mw4, n1, n2
type (mp_realm) b(n2,n2)
type (mp_real) a(n1,n2), c(n2), t1, t2

do i = 1, n1
  do j = 1, n2
    t1 = 0.d0

    do k = 1, n2
      t1 = t1 + a(i,k) * b(k,j)
    enddo

    c(j) = t1
  enddo

  do j = 1, n2
    a(i,j) = c(j)
  enddo
enddo

return
end