module test_params

  use numbers_module, only : wp
  implicit none
  Logical, Parameter :: verbose = .False.

  Integer :: me, nproc
  Integer :: n, m, k
  Integer :: n_block
  Integer :: ns, nk
  Integer :: error

  Integer, parameter :: n_def = 101
  Integer, parameter :: m_def = 203
  Integer, parameter :: k_def = 129
  Integer, parameter :: n_block_def = 11
  Integer, parameter :: ns_def = 2
  integer, parameter :: nk_def = 3

  Character( Len = * ), Parameter :: error_format = '( "--> ", a, t44, g26.20, t72, a )'
  Character( Len = * ), Parameter ::   run_format = '( a, t20, i0 )'
  Character( Len = * ), Parameter :: title_format = '( t5, a )'
  Character( Len = * ), Parameter :: passed       = 'Passed      '
  Character( Len = * ), Parameter :: FAILED       = '      FAILED'

  Real( wp ), Parameter :: tol = 1.0e-11_wp

end module test_params


  MODULE maxmin_module

  CONTAINS

      subroutine maxmin(izz,jzz,kzz,f,nstat,rstat,kmin,kmax,amax,amin)
      use input
      use mpi
      implicit none

      integer :: izz,jzz,kzz,nstat,kmin,kmax
      real, dimension(stat_out) :: rstat
      real, dimension(1-ngxy:izz+ngxy,1-ngxy:jzz+ngxy,1-ngz:kzz+ngz) :: f
      character(len=6) :: amax,amin

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

      integer :: i,j,k
      integer :: imax,jmax,imin,jmin
      integer, dimension(nk+1) :: imaxt,jmaxt,kmaxt,imint,jmint,kmint
      real, dimension(nk+1) :: tmax,tmin
      real :: fmax,fmin,rmax,rmin
      integer :: loc
      real, dimension(2) :: mmax,nmax,mmin,nmin

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

      imin = 1
      jmin = 1
      kmin = 1
      imax = 1
      jmax = 1
      kmax = 1

!$omp parallel do default(shared)    &
!$omp private(i,j,k)
      do k=1,kzz
        tmax(k)= -1.e30
        tmin(k)=  1.e30
        do j=1,jzz
        do i=1,izz
          if(f(i,j,k).gt.tmax(k))then
            tmax(k)=f(i,j,k)
            imaxt(k)=i
            jmaxt(k)=j
            kmaxt(k)=k
          endif
          if(f(i,j,k).lt.tmin(k))then
            tmin(k)=f(i,j,k)
            imint(k)=i
            jmint(k)=j
            kmint(k)=k
          endif
        enddo
        enddo
      enddo

      fmax= -1.e30
      fmin=  1.e30
      do k=1,kzz
        if(tmax(k).gt.fmax)then
          fmax=tmax(k)
          imax=imaxt(k)
          jmax=jmaxt(k)
          kmax=kmaxt(k)
        endif
        if(tmin(k).lt.fmin)then
          fmin=tmin(k)
          imin=imint(k)
          jmin=jmint(k)
          kmin=kmint(k)
        endif
      enddo

      mmax(1)=fmax
      mmax(2)=myid
      call MPI_ALLREDUCE(mmax,nmax,1,MPI_2REAL,MPI_MAXLOC,   &
                         MPI_COMM_WORLD,ierr)
      loc=nint(nmax(2))
      imax=imax+(myi-1)*ni
      jmax=jmax+(myj-1)*nj
      call MPI_BCAST(imax,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)
      call MPI_BCAST(jmax,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)
      call MPI_BCAST(kmax,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)

      mmin(1)=fmin
      mmin(2)=myid
      call MPI_ALLREDUCE(mmin,nmin,1,MPI_2REAL,MPI_MINLOC,   &
                         MPI_COMM_WORLD,ierr)
      loc=nint(nmin(2))
      imin=imin+(myi-1)*ni
      jmin=jmin+(myj-1)*nj
      call MPI_BCAST(imin,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)
      call MPI_BCAST(jmin,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)
      call MPI_BCAST(kmin,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)

      fmax=nmax(1)
      fmin=nmin(1)

    if(myid.eq.0)then
      write(6,100) amax,fmax,imax,jmax,kmax,    &
                   amin,fmin,imin,jmin,kmin
100   format(2x,a6,':',1x,g13.6,i5,i5,i5,    &
             4x,a6,':',1x,g13.6,i5,i5,i5)

      nstat = nstat + 1
      rstat(nstat) = fmax
      nstat = nstat + 1
      rstat(nstat) = fmin
    endif

      if(timestats.ge.1) time_stat=time_stat+mytime()

      end subroutine maxmin

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine maxmin2d(izz,jzz,f,nstat,rstat,amax,amin)
      use input
      use mpi
      implicit none

      integer :: izz,jzz,nstat
      real, dimension(stat_out) :: rstat
      real, dimension(1-ngxy:izz+ngxy,1-ngxy:jzz+ngxy) :: f
      character(len=6) :: amax,amin

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

      integer :: i,j
      integer :: imax,jmax,imin,jmin
      integer, dimension(jzz) :: imaxt,jmaxt,imint,jmint
      real, dimension(jzz) :: tmax,tmin
      real :: fmax,fmin,rmax,rmin
      integer :: loc
      real, dimension(2) :: mmax,nmax,mmin,nmin

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

!$omp parallel do default(shared)    &
!$omp private(i,j)
      do j=1,jzz
        tmax(j)= -1.e30
        tmin(j)=  1.e30
        do i=1,izz
          if(f(i,j).gt.tmax(j))then
            tmax(j)=f(i,j)
            imaxt(j)=i
            jmaxt(j)=j
          endif
          if(f(i,j).lt.tmin(j))then
            tmin(j)=f(i,j)
            imint(j)=i
            jmint(j)=j
          endif
        enddo
      enddo

      fmax= -1.e30
      fmin=  1.e30
      do j=1,jzz
        if(tmax(j).gt.fmax)then
          fmax=tmax(j)
          imax=imaxt(j)
          jmax=jmaxt(j)
        endif
        if(tmin(j).lt.fmin)then
          fmin=tmin(j)
          imin=imint(j)
          jmin=jmint(j)
        endif
      enddo

      mmax(1)=fmax
      mmax(2)=myid
      call MPI_ALLREDUCE(mmax,nmax,1,MPI_2REAL,MPI_MAXLOC,   &
                         MPI_COMM_WORLD,ierr)
      loc=nint(nmax(2))
      imax=imax+(myi-1)*ni
      jmax=jmax+(myj-1)*nj
      call MPI_BCAST(imax,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)
      call MPI_BCAST(jmax,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)

      mmin(1)=fmin
      mmin(2)=myid
      call MPI_ALLREDUCE(mmin,nmin,1,MPI_2REAL,MPI_MINLOC,   &
                         MPI_COMM_WORLD,ierr)
      loc=nint(nmin(2))
      imin=imin+(myi-1)*ni
      jmin=jmin+(myj-1)*nj
      call MPI_BCAST(imin,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)
      call MPI_BCAST(jmin,1,MPI_INTEGER,loc,MPI_COMM_WORLD,ierr)

      fmax=nmax(1)
      fmin=nmin(1)

    if(myid.eq.0)then
      write(6,100) amax,fmax,imax,jmax,1,    &
                   amin,fmin,imin,jmin,1
100   format(2x,a6,':',1x,g13.6,i5,i5,i5,    &
             4x,a6,':',1x,g13.6,i5,i5,i5)

      nstat = nstat + 1
      rstat(nstat) = fmax
      nstat = nstat + 1
      rstat(nstat) = fmin
    endif

      if(timestats.ge.1) time_stat=time_stat+mytime()

      end subroutine maxmin2d

  END MODULE maxmin_module


MODULE constants_NSWC
! Contains the NSWC functions SPMPAR, DPMPAR, EPSLN, DEPSLN, EXPARG & DXPARG
!-----------------------------------------------------------------------
!     WRITTEN using F90 intrinsics by
!        Alan Miller
!        CSIRO Mathematical & Information Sciences
!        CLAYTON, VICTORIA, AUSTRALIA 3169
!     Latest revision - 1 February 1997
!-----------------------------------------------------------------------

IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)

CONTAINS

FUNCTION spmpar (i) RESULT(fn_val)
!-----------------------------------------------------------------------

!     SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR
!     THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
!     I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
!     SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
!     ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN

!        SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,

!        SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,

!        SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
!-----------------------------------------------------------------------

IMPLICIT NONE
INTEGER, INTENT(IN) :: i
REAL                :: fn_val

! Local variable
REAL                :: one = 1.0

SELECT CASE (i)
  CASE (1)
    fn_val = EPSILON(one)
  CASE (2)
    fn_val = TINY(one)
  CASE (3)
    fn_val = HUGE(one)
END SELECT

RETURN
END FUNCTION spmpar

FUNCTION dpmpar (i) RESULT(fn_val)
!-----------------------------------------------------------------------

!     DPMPAR PROVIDES THE DOUBLE PRECISION MACHINE CONSTANTS FOR
!     THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
!     I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
!     DOUBLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
!     ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN

!        DPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,

!        DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,

!        DPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
!-----------------------------------------------------------------------

IMPLICIT NONE
INTEGER, INTENT(IN) :: i
REAL (dp)           :: fn_val

! Local variable
REAL (dp)    :: one = 1._dp

SELECT CASE (i)
  CASE (1)
    fn_val = EPSILON(one)
  CASE (2)
    fn_val = TINY(one)
  CASE (3)
    fn_val = HUGE(one)
END SELECT

RETURN
END FUNCTION dpmpar

FUNCTION epsln () RESULT(fn_val)
!--------------------------------------------------------------------
!     THE EVALUATION OF LN(EPS) WHERE EPS IS THE SMALLEST NUMBER
!     SUCH THAT 1.0 + EPS .GT. 1.0 .  L IS A DUMMY ARGUMENT.
!--------------------------------------------------------------------
IMPLICIT NONE
REAL                :: fn_val

! Local variable
REAL                :: one = 1.0

fn_val = LOG( EPSILON(one) )
RETURN
END FUNCTION epsln

FUNCTION exparg (l) RESULT(fn_val)
!--------------------------------------------------------------------
!     IF L = 0 THEN  EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
!     EXP(W) CAN BE COMPUTED.
!
!     IF L IS NONZERO THEN  EXPARG(L) = THE LARGEST NEGATIVE W FOR
!     WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO.
!
!     NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED.
!--------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: l
REAL                :: fn_val

! Local variable
REAL                :: one = 1.0

IF (l == 0) THEN
  fn_val = LOG( HUGE(one) )
ELSE
  fn_val = LOG( TINY(one) )
END IF
RETURN
END FUNCTION exparg

FUNCTION depsln () RESULT(fn_val)
!--------------------------------------------------------------------
!     THE EVALUATION OF LN(EPS) WHERE EPS IS THE SMALLEST NUMBER
!     SUCH THAT 1.D0 + EPS .GT. 1.D0 .  L IS A DUMMY ARGUMENT.
!--------------------------------------------------------------------
IMPLICIT NONE
REAL (dp)           :: fn_val

! Local variable
REAL (dp)    :: one = 1._dp

fn_val = LOG( EPSILON(one) )
RETURN
END FUNCTION depsln

FUNCTION dxparg (l) RESULT(fn_val)
!--------------------------------------------------------------------
!     IF L = 0 THEN  DXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
!     DEXP(W) CAN BE COMPUTED.
!
!     IF L IS NONZERO THEN  DXPARG(L) = THE LARGEST NEGATIVE W FOR
!     WHICH THE COMPUTED VALUE OF DEXP(W) IS NONZERO.
!
!     NOTE... ONLY AN APPROXIMATE VALUE FOR DXPARG(L) IS NEEDED.
!--------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: l
REAL (dp)           :: fn_val

! Local variable
REAL (dp)    :: one = 1._dp

IF (l == 0) THEN
  fn_val = LOG( HUGE(one) )
ELSE
  fn_val = LOG( TINY(one) )
END IF
RETURN
END FUNCTION dxparg

END MODULE constants_NSWC

SUBROUTINE smplx (a, b0, c, ka, m, n0, ind, ibasis, x, z, iter, mxiter,   &
                  numle, numge, bi, rerr)
!-----------------------------------------------------------------------
!     SIMPLEX PROCEDURE FOR SOLVING LINEAR PROGRAMMING PROBLEMS
!-----------------------------------------------------------------------
! Finds non-negative x's to maximize:
!     c1.x1 + ... + cn.xn
!
! Subject to the constraints:
!     a11.x1 + ... + a1n.xn {<=,=,>=} b1
!              ...
!     am1.x1 + ... + amn.xn {<=,=,>=} bm
!
! The constraints must be ordered so that the <= constraints, if any, come
! first, then any >= constraints, with the equality constraints last.
!
! Arguments:
! a(ka,n0)   INPUT   coefficients in the constraints.
! b0(m)      INPUT   right-hand side of the constraints.
! c(n0)      INPUT   vector of `costs' in the objective function.
! ka         INPUT   first dimension of array a.
! m          INPUT   dimension of array b0.
! n0         INPUT   2nd dimension of array a.
! ind        IN/OUT  If IND = 0 on input, the routine selects its own initial
!                    basis, else if IND = 1 then the indices of the initial
!                    basis should be in IBASIS.
!                    On output:
!                    IND = 0 the problem was solved
!                    IND = 1 the problem has no solution
!                    IND = 2 MXITER iterations were performed; more needed
!                    IND = 3 sufficient accuracy could not be maintained to
!                            solve the problem
!                    IND = 4 the problem has an unbounded solution
!                    IND = 5 input error detected
!                    IND = 6 the solution may have been obtained
! ibasis(m)  IN/OUT  indices of the variables in the basis.
! x()        OUTPUT  Dimension must be >= n + numle + numge.
!                    If IND = 0 or 6, it contains the values of the original,
!                    slack and surplus variables.
! z          OUTPUT  If IND = 0 or 6, contains the value of the objective.
! iter       OUTPUT  number of iterations used.
! mxiter     INPUT   maximum number of iterations.
! numle      INPUT   number of <= constraints.
! numge      INPUT   number of >= constraints.
! bi(m,m)    OUTPUT  the inverse of the basis matrix.
! rerr       OUTPUT  the estimated relative error achieved.
! N.B. The last two arguments in the NSWC routine have been eliminated.
!      These were work spaces.   They are now declared as automatic arrays.
!-----------------------------------------------------------------------
!     WRITTEN BY ALFRED H. MORRIS JR.
!        NAVAL SURFACE WEAPONS CENTER
!        DAHLGREN, VIRGINIA
!------------------------
!     INITIAL VERSION  DEC  1977
!     LAST UPDATE      OCT  1990
!-----------------------------------------------------------------------
!     Converted using F90 intrinsics by
!        Alan Miller
!        CSIRO Mathematical & Information Sciences
!        CLAYTON, VICTORIA, AUSTRALIA 3169
!     Latest revision - 5 February 1997
!-----------------------------------------------------------------------

USE constants_NSWC
IMPLICIT NONE

INTEGER, INTENT(IN)                    :: ka, m, n0, mxiter, numle, numge
INTEGER, INTENT(IN OUT)                :: ind
INTEGER, DIMENSION(:), INTENT(IN OUT)  :: ibasis
INTEGER, INTENT(OUT)                   :: iter
REAL (dp), DIMENSION(:,:), INTENT(IN)  :: a
REAL (dp), DIMENSION(:), INTENT(IN)    :: b0, c
REAL (dp), INTENT(OUT)                 :: z, rerr
REAL (dp), DIMENSION(:), INTENT(OUT)   :: x
REAL (dp), DIMENSION(:,:), INTENT(OUT) :: bi

INTERFACE
  SUBROUTINE smplx1 (a, b0, c, ka, m, n0, ind, ibasis, r, z, iter, mxiter,  &
                     eps0, rerrmn, rerrmx, rerr, numle, numge, bi)
    USE constants_NSWC
    IMPLICIT NONE
    INTEGER, INTENT(IN)                    :: ka, m, n0, mxiter, numle, numge
    INTEGER, INTENT(OUT)                   :: ind, iter
    REAL (dp), DIMENSION(:,:), INTENT(IN)  :: a
    REAL (dp), DIMENSION(:), INTENT(IN)    :: b0, c
    REAL (dp), DIMENSION(:,:), INTENT(OUT) :: bi
    REAL (dp), DIMENSION(:), INTENT(OUT)   :: r
    REAL (dp), INTENT(OUT)                 :: z, rerr
    REAL (dp), INTENT(IN)                  :: eps0, rerrmn, rerrmx
    INTEGER, DIMENSION(:), INTENT(IN OUT)  :: ibasis
  END SUBROUTINE smplx1
END INTERFACE

!------------------------
!     DIMENSION X(N0+NUMLE+NUMGE)
!------------------------

!     ********** EPS0 IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS0
!                THE VALUE U WHERE U IS THE SMALLEST POSITIVE FLOATING
!                POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0.

!     Local variables
REAL (dp) :: eps0, rerrmn, rerrmx

eps0 = dpmpar(1)

!------------------------
rerrmn = 10.0_dp*eps0
rerrmx = 1.d-4
IF (eps0 < 1.d-13) rerrmx = 1.d-5

CALL smplx1(a, b0, c, ka, m, n0, ind, ibasis, x, z, iter, mxiter, eps0,   &
        rerrmn, rerrmx, rerr, numle, numge, bi)
RETURN
END SUBROUTINE smplx

SUBROUTINE smplx1 (a, b0, c, ka, m, n0, ind, ibasis, r, z, iter, mxiter,  &
                   eps0, rerrmn, rerrmx, rerr, numle, numge, bi)
!----------------------
!     NSTEP = 1   ELIMINATE THE NEGATIVE VARIABLES
!     NSTEP = 2   PHASE 1 OF THE SIMPLEX ALGORITHM
!     NSTEP = 3   PHASE 2 OF THE SIMPLEX ALGORITHM
!----------------------
!     MXITER = THE MAXIMUM NUMBER OF ITERATIONS PERMITTED
!     ITER = THE NUMBER OF THE CURRENT ITERATION
!     ICOUNT = THE NUMBER OF ITERATIONS SINCE THE LAST INVERSION
!----------------------
!     NUMLE = THE NUMBER OF .LE. CONSTRAINTS
!     NUMGE = THE NUMBER OF .GE. CONSTRAINTS
!----------------------
!     THE ROUTINE ASSUMES THAT THE .LE. CONSTRAINTS PRECEDE THE .GE.
!     CONSTRAINTS AND THAT THE .EQ. CONSTRAINTS COME LAST. THERE ARE
!     M CONSTRAINTS. X(N0+I) IS THE SLACK, SURPLUS, OR ARTIFICIAL
!     VARIABLE FOR THE I-TH CONSTRAINT (I=1, ..., M).
!----------------------
!     N0 = THE NUMBER OF ORGINAL VARIABLES
!     NS = THE NUMBER OF ORGINAL AND SLACK VARIABLES
!     N  = THE NUMBER OF ORGINAL, SLACK, AND SURPLUS VARIABLES
!     NUM = THE TOTAL NUMBER OF VARIABLES
!----------------------
!     RERRMN = THE SMALLEST RELATIVE ERROR TOLERANCE USED
!     RERRMX = THE LARGEST RELATIVE ERROR TOLERACE USED
!     RERR   = THE ESTIMATED CURRENT RELATIVE ERROR
!----------------------
!     ASSUME THAT
!         B0 = (B0(1), ..., B0(M))
!         C  = (C(1), ..., C(N0))
!         Z  = C(1)*X(1)+...+C(N0)*X(N0)
!     THE PROBLEM IS TO MAXIMIZE Z SUBJECT TO
!         AX(LE,EQ,GE)B0
!         X.GE.0
!----------------------
!     ON INPUT IND CAN HAVE THE VALUES
!         IND = 0   NO BEGINNING BASIS IS PROVIDED BY THE USER
!         IND = 1   THE ARRAY IBASIS HAS BEEN SET BY THE USER
!     ON OUTPUT IND IS ASSIGNED ONE OF THE VALUES
!         IND = 0   Z WAS SUCCESSFULLY MAXIMIZED
!         IND = 1   THE PROBLEM HAS NO FEASIBLE SOLUTION
!         IND = 2   MXITER ITERATIONS WERE PERFORMED
!         IND = 3   SUFFICIENT ACCURACY CANNOT BE MAINTAINED
!         IND = 4   THE PROBLEM HAS AN UNBOUNDED SOLUTION
!         IND = 5   THERE IS AN INPUT ERROR
!         IND = 6   Z WAS POSSIBLY MAXIMIZED
!----------------------
!     BASIS IS AN INTEGER ARRAY OF DIMENSION N0+M. FOR J.LE.N
!         BASIS(J) = 1  IF X(J) IS A BASIC VARIABLE
!         BASIS(J) = 0  IF X(J) IS NOT A BASIC VARIABLE
!     IF THE BASIC VARIABLES ARE X(I1), ..., X(IM) THEN
!         IBASIS = (I1, ..., IM)
!     ALSO XB(1), ..., XB(M) ARE THE CORRESPONDING VALUES OF THE
!     BASIC VARIABLES.
!----------------------
!     BI IS AN MXM ARRAY CONTAINING THE INVERSE OF THE BASIS MATRIX.
!----------------------
!     R IS AN ARRAY OF DIMENSION N. ON OUTPUT R CONTAINS THE CURRENT
!     VALUE OF X. DURING COMPUTATION R NORMALLY CONTAINS THE REDUCED
!     COSTS USED FOR THE SELECTION OF THE VARIABLE TO BE MADE BASIC.
!----------------------
USE constants_NSWC
IMPLICIT NONE
INTEGER, INTENT(IN)                    :: ka, m, n0, mxiter, numle, numge
INTEGER, INTENT(OUT)                   :: ind, iter
REAL (dp), DIMENSION(:,:), INTENT(IN)  :: a
REAL (dp), DIMENSION(:), INTENT(IN)    :: b0, c
REAL (dp), DIMENSION(:,:), INTENT(OUT) :: bi
REAL (dp), DIMENSION(:), INTENT(OUT)   :: r
REAL (dp), INTENT(OUT)                 :: z, rerr
REAL (dp), INTENT(IN)                  :: eps0, rerrmn, rerrmx
INTEGER, DIMENSION(:), INTENT(IN OUT)  :: ibasis
!----------------------

INTERFACE
  SUBROUTINE crout1(a, ka, n, iend, indx, temp, ierr)
    USE constants_NSWC
    IMPLICIT NONE
    INTEGER, INTENT(IN)                     :: ka, n, iend
    INTEGER, INTENT(OUT)                    :: ierr
    REAL (dp), DIMENSION(:), INTENT(IN OUT) :: a, temp
    INTEGER, DIMENSION(:), INTENT(IN OUT)   :: indx
  END SUBROUTINE crout1
END INTERFACE

!     Local variables
INTEGER   :: i, ibeg, icount, iend, ierr, ii, il, imin, iout, ip, j, jj,  &
             jmin, jp, k, ki, kj, l, ll, lrow, m0, mcheck, ms, n, npos,   &
             nrow, ns, nstep, num, bflag
REAL (dp) :: xb(m), y(m)
INTEGER   :: basis(m+n0), indx(m)
REAL (dp) :: amax, binorm, bmax, bmin, bnorm, cmin, const, eps, epsi, ratio, &
             rerr1, rmin, rtol, s, sgn, t, tol, total, w, xmax, zero = 0._dp, &
             dsum, dsump, dsumn, dt

!     ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE
!            LARGEST POSITIVE FLOATING POINT NUMBER.

xmax = dpmpar(3)

!----------------------
iter = 0
icount = 0
mcheck = MIN(5, 1 + m/15)
z = zero

!                CHECK FOR INPUT ERRORS

ms = numle + numge
IF (m < 2 .OR. n0 < 2 .OR. ms > m .OR. ka < m)  &
GO TO 12
DO i = 1, m
  IF (b0(i) < zero) GO TO 12
  xb(i) = zero
END DO
rtol = xmax
DO i = 1, n0
  IF (c(i) /= zero) rtol = MIN(ABS(c(i)), rtol)
END DO
rtol = rerrmx*rtol
GO TO 20

12 ind = 5
RETURN

!     FORMATION OF THE IBASIS AND BASIS ARRAYS.
!     (IF IND = 1  THEN THE IBASIS ARRAY IS DEFINED BY THE USER.)

20 ns = n0 + numle
n = ns + numge
IF (ind == 0) GO TO 30
num = n
DO i = 1, m
  IF (ibasis(i) > n) num = num + 1
END DO
GO TO 32
22 IF (ind == 0) GO TO 590
ind = 0

30 num = n0 + m
DO i = 1, m
  ibasis(i) = n0 + i
END DO
32 bflag = 0
basis(1:n) = 0
DO i = 1, m
  ki = ibasis(i)
  basis(ki) = 1
END DO
IF (ind == 1) GO TO 100

!          CALCULATION OF XB AND BI WHEN IND = 0

rerr = rerrmn
DO j = 1, m
  xb(j) = b0(j)
  bi(1:m,j) = zero
  bi(j,j) = 1.0_dp
END DO
IF (numge == 0) GO TO 630
jmin = numle + 1
DO j = jmin, ms
  xb(j) = -xb(j)
  bi(j,j) = -1.0_dp
END DO
GO TO 601

!                  REORDER THE BASIS

100 ibeg = 1
iend = m
DO i = 1, m
  IF (ibasis(i) > n0) THEN
    indx(ibeg) = ibasis(i)
    ibeg = ibeg + 1
  ELSE
    indx(iend) = ibasis(i)
    iend = iend - 1
  END IF
END DO
IF (iend == m) GO TO 22
ibasis(1:m) = indx(1:m)

!            REINVERSION OF THE BASIS MATRIX

DO j = 1, m
  kj = ibasis(j)
  IF (kj <= n0) GO TO 110
  IF (kj <= ns) GO TO 120
  IF (kj <= n) GO TO 130
  GO TO 120

  110 bi(1:m,j) = a(1:m,kj)
  CYCLE

  120 l = kj - n0
  bi(1:m,j) = zero
  bi(l,j) = 1.0_dp
  CYCLE

  130 l = kj - n0
  bi(1:m,j) = zero
  bi(l,j) = -1.0_dp
END DO

icount = 0
CALL crout1 (bi(1:,1), m, m, iend, indx, y, ierr)
IF (ierr /= 0) GO TO 580

!         CHECK THE ACCURACY OF BI AND RESET RERR

bnorm = zero
DO j = 1, m
  kj = ibasis(j)
  IF (kj <= n0) GO TO 140
  total = 1.0_dp
  GO TO 142
  140 total = SUM( ABS(a(1:m,kj)) )
  142 bnorm = MAX(bnorm, total)
END DO

binorm = zero
DO j = 1, m
  total = SUM( ABS(bi(1:m,j)) )
  binorm = MAX(binorm, total)
END DO
rerr = MAX(rerrmn, eps0*bnorm*binorm)
IF (rerr > 1.d-2) GO TO 580
bflag = 0

!                 RECALCULATION OF XB

DO i = 1, m
  dsump = zero
  dsumn = zero
  DO l = 1, m
    dt = bi(i,l)*b0(l)
    IF (dt > zero) THEN
      dsump = dsump + dt
    ELSE
      dsumn = dsumn + dt
    END IF
  END DO
  xb(i) = dsump + dsumn
  s = dsump
  t = dsumn
  tol = rerrmx*MAX(s, -t)
  IF (ABS(xb(i)) < tol) xb(i) = zero
END DO
GO TO 601

!     FIND THE NEXT VECTOR A(--, JP) TO BE INSERTED INTO THE BASIS

200 jp = 0
rmin = zero
IF (nstep == 3) rmin = -rtol
DO j = 1, n0
  IF (basis(j) /= 0) CYCLE
  IF (r(j) >= rmin) CYCLE
  jp = j
  rmin = r(j)
END DO
IF (n0 == n) GO TO 203
jmin = n0 + 1
rmin = rmin*1.1_dp
DO j = jmin, n
  IF (basis(j) /= 0) CYCLE
  IF (r(j) >= rmin) CYCLE
  jp = j
  rmin = r(j)
END DO
203 IF (jp /= 0) GO TO 300
IF (nstep < 2) THEN
   GO TO 800
ELSE IF (nstep == 2) THEN
  GO TO 230
ELSE
  GO TO 250
END IF

!     INSERT THE VALUES OF THE ORGINAL, SLACK, AND SURPLUS
!             VARIABLES INTO R, THEN TERMINATE.

220 r(1:n) = zero
DO i = 1, m
  ki = ibasis(i)
  IF (ki <= n) r(ki) = xb(i)
END DO
RETURN

!             COMPLETION OF THE NSTEP = 2 CASE

230 DO i = 1, m
  IF (ibasis(i) <= n) CYCLE
  IF (xb(i) > zero) GO TO 800
END DO
GO TO 680

240 IF (icount >= 5) GO TO 100
ind = 1
GO TO 220

!             COMPLETION OF THE NSTEP = 3 CASE

250 IF (rerr > 1.d-2) GO TO 251
ind = 0
GO TO 800
251 IF (icount >= 5) GO TO 100
ind = 6
GO TO 800

!     IF MXITER ITERATIONS HAVE NOT BEEN PERFORMED THEN BEGIN THE
!     NEXT ITERATION. COMPUTE THE JP-TH COLUMN OF BI*A AND STORE IT IN Y.

300 IF (iter < mxiter) GO TO 301
ind = 2
GO TO 220
301 iter = iter + 1
icount = icount + 1
IF (jp > ns) GO TO 330
IF (jp > n0) GO TO 320

nrow = 0
amax = zero
DO i = 1, m
  IF (a(i,jp) == zero) CYCLE
  nrow = nrow + 1
  indx(nrow) = i
  amax = MAX(ABS(a(i,jp)), amax)
END DO
IF (nrow /= 0) GO TO 310
ind = 4
GO TO 220

310 rerr1 = rerrmx*amax
DO i = 1, m
  dsum = zero
  DO ll = 1, nrow
    l = indx(ll)
    dsum = dsum + bi(i,l)*a(l,jp)
  END DO
  y(i) = dsum
  IF (ABS(y(i)) >= 5.d-3) CYCLE
  bmax = zero
  DO l = 1, m
    bmax = MAX(ABS(bi(i,l)), bmax)
  END DO
  tol = rerr1*bmax
  IF (ABS(y(i)) < tol) y(i) = zero
END DO
GO TO 350

320 l = jp - n0
y(1:m) = bi(1:m,l)
GO TO 350

330 l = jp - n0
y(1:m) = -bi(1:m,l)

350 DO i = 1, m
  IF (y(i) /= zero) GO TO 360
END DO
r(jp) = zero
iter = iter - 1
icount = icount - 1
GO TO 200

360 IF (nstep == 2) GO TO 430
IF (nstep > 2) GO TO 440

!     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC FOR THE NSTEP = 1 CASE

npos = 0
ip = 0
eps = zero
epsi = xmax
DO i = 1, m
  IF (xb(i) < zero .OR. y(i) <= zero) CYCLE
  ratio = xb(i)/y(i)
  IF (ratio < epsi) THEN
    epsi = ratio
    npos = 1
    indx(1) = i
    CYCLE
  ELSE IF (ratio > epsi) THEN
    CYCLE
  END IF
  npos = npos + 1
  indx(npos) = i
END DO
IF (npos == 0) GO TO 420
IF (epsi == zero) GO TO 460

DO i = 1, m
  IF (xb(i) >= zero .OR. y(i) >= zero) CYCLE
  ratio = xb(i)/y(i)
  IF (ratio > epsi) CYCLE
  IF (ratio < eps) CYCLE
  eps = ratio
  ip = i
END DO
IF (ip /= 0) GO TO 500
GO TO 460

420 DO i = 1, m
  IF (xb(i) >= zero .OR. y(i) >= zero) CYCLE
  ratio = xb(i)/y(i)
  IF (ratio < eps) CYCLE
  eps = ratio
  ip = i
END DO
GO TO 500

!     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC FOR THE NSTEP = 2 CASE

430 npos = 0
epsi = xmax
DO i = 1, m
  IF (y(i) <= zero) CYCLE
  ratio = xb(i)/y(i)
  IF (ratio < epsi) THEN
    epsi = ratio
    npos = 1
    indx(1) = i
  ELSE IF (ratio > epsi) THEN
    CYCLE
  END IF
  npos = npos + 1
  indx(npos) = i
END DO
GO TO 450

!     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC FOR THE NSTEP = 3 CASE

440 npos = 0
epsi = xmax
DO i = 1, m
  IF (y(i) < zero) THEN
    IF (ibasis(i) <= n) CYCLE
    ip = i
    GO TO 500
  ELSE IF (y(i) > zero) THEN
    ratio = xb(i)/y(i)
    IF (ratio < epsi) THEN
      epsi = ratio
      npos = 1
      indx(1) = i
    ELSE IF (ratio > epsi) THEN
      CYCLE
    END IF
    npos = npos + 1
    indx(npos) = i
  END IF
END DO

450 IF (npos /= 0) GO TO 460
IF (icount >= 5) GO TO 100
ind = 4
GO TO 220

!              TIE BREAKING PROCEDURE

460 ip = indx(1)
IF (npos == 1) GO TO 500
ip = 0
bmin = xmax
cmin = xmax
DO ii = 1, npos
  i = indx(ii)
  l = ibasis(i)
  IF (l > n0) GO TO 461
  IF (c(l) <= zero) cmin = MIN(zero, cmin)
  IF (c(l) > cmin) CYCLE
  imin = i
  cmin = c(l)
  CYCLE
  461 IF (l <= n) GO TO 462
  ip = i
  GO TO 500
  462 lrow = l - n0
  s = b0(lrow)
  IF (lrow <= numle) THEN
    IF (s > bmin) CYCLE
    ip = i
    bmin = s
  ELSE
    s = -s
    bmin = MIN(zero, bmin)
    IF (s > bmin) CYCLE
    ip = i
    bmin = s
  END IF
END DO
IF (cmin <= zero .OR. ip == 0) ip = imin

!               TRANSFORMATION OF XB

500 IF (xb(ip) == zero) GO TO 510
const = xb(ip)/y(ip)
DO i = 1, m
  s = xb(i)
  xb(i) = xb(i) - const*y(i)
  IF (xb(i) >= zero) CYCLE
  IF (s >= zero .OR. xb(i) >= rerrmx*s) xb(i) = zero
END DO
xb(ip) = const

!               TRANSFORMATION OF BI

510 DO j = 1, m
  IF (bi(ip,j) == zero) CYCLE
  const = bi(ip,j)/y(ip)
  bi(1:m,j) = bi(1:m,j) - const*y(1:m)
  bi(ip,j) = const
END DO

!             UPDATING IBASIS AND BASIS

iout = ibasis(ip)
ibasis(ip) = jp
basis(iout) = 0
basis(jp) = 1
IF (iout > n) num = num - 1

!        CHECK THE ACCURACY OF BI AND RESET RERR

IF (rerr > 1.d-2) GO TO 530
k = 0
DO j = 1, m
  kj = ibasis(j)
  IF (kj > n0) CYCLE
  total = DOT_PRODUCT( bi(j,1:m), a(1:m, kj) )
  rerr = MAX(rerr, ABS(1.0_dp - total))
  k = k + 1
  IF (k >= mcheck) GO TO 522
END DO
522 IF (rerr <= 1.d-2) GO TO 600

!        THE ACCURACY CRITERIA ARE NOT SATISFIED

530 IF (icount < 5) GO TO 600
bflag = 1
GO TO 100

580 IF (iter == 0) GO TO 12
IF (bflag == 0) GO TO 590
bflag = 0
DO ip = 1, m
  IF (jp == ibasis(ip)) GO TO 582
END DO
582 ibasis(ip) = iout
basis(jp) = 0
basis(iout) = 1
IF (iout > n) num = num + 1
GO TO 100

590 ind = 3
GO TO 220

!       SET UP THE R ARRAY FOR THE NSTEP = 1 CASE

600 IF (nstep == 2) GO TO 630
IF (nstep > 2) GO TO 700
601 DO j = 1, m
  IF (xb(j) < zero) GO TO 610
END DO
GO TO 630

610 nstep = 1
m0 = 0
DO l = 1, m
  IF (xb(l) >= zero) CYCLE
  m0 = m0 + 1
  indx(m0) = l
END DO

DO j = 1, m
  dsump = zero
  dsumn = zero
  DO ll = 1, m0
    l = indx(ll)
    IF (bi(l,j) < zero) THEN
      dsumn = dsumn + bi(l,j)
    ELSE IF (bi(l,j) > zero) THEN
      dsump = dsump + bi(l,j)
    END IF
  END DO
  y(j) = dsump + dsumn
  s = dsump
  t = dsumn
  tol = rerrmx*MAX(s, -t)
  IF (ABS(y(j)) < tol) y(j) = zero
END DO
GO TO 650

!       SET UP THE R ARRAY FOR THE NSTEP = 2 CASE

630 IF (n == num) GO TO 680
nstep = 2
m0 = 0
DO l = 1, m
  IF (ibasis(l) <= n) CYCLE
  m0 = m0 + 1
  indx(m0) = l
END DO

DO j = 1, m
  dsump = zero
  dsumn = zero
  DO ll = 1, m0
    l = indx(ll)
    IF (bi(l,j) < zero) THEN
      dsumn = dsumn + bi(l,j)
    ELSE IF (bi(l,j) > zero) THEN
      dsump = dsump + bi(l,j)
    END IF
  END DO
  y(j) = -(dsump + dsumn)
  s = dsump
  t = dsumn
  tol = rerrmx*MAX(s, -t)
  IF (ABS(y(j)) < tol) y(j) = zero
END DO

650 DO j = 1, n0
  IF (basis(j) == 0) THEN
    r(j) = DOT_PRODUCT( y(1:m), a(1:m,j) )
  ELSE
    r(j) = zero
  END IF
END DO

660 IF (n0 == ns) GO TO 670
jmin = n0 + 1
DO j = jmin, ns
  r(j) = zero
  IF (basis(j) /= 0) CYCLE
  jj = j - n0
  r(j) = y(jj)
END DO

670 IF (ns == n) GO TO 200
jmin = ns + 1
DO j = jmin, n
  r(j) = zero
  IF (basis(j) /= 0) CYCLE
  jj = j - n0
  r(j) = -y(jj)
END DO
GO TO 200

!      SET UP A NEW R ARRAY FOR THE NSTEP = 3 CASE

680 nstep = 3
DO j = 1, m
  dsum = zero
  DO l = 1, m
    il = ibasis(l)
    IF (il <= n0) dsum = dsum + c(il)*bi(l,j)
  END DO
  y(j) = dsum
END DO

DO j = 1, n0
  r(j) = zero
  IF (basis(j) /= 0) CYCLE
  dsum = -c(j) + DOT_PRODUCT( y(1:m), a(1:m,j) )
  r(j) = dsum
  IF (r(j) >= zero) CYCLE
  tol = rerrmx*ABS(c(j))
  IF (ABS(r(j)) < tol) r(j) = zero
END DO
GO TO 660

!       UPDATE THE R ARRAY FOR THE NSTEP = 3 CASE

700 const = r(jp)
DO j = 1, n0
  IF (basis(j) /= 0) THEN
    r(j) = zero
  ELSE
    total = DOT_PRODUCT( bi(ip,1:m), a(1:m,j) )
    r(j) = r(j) - const*total
    IF (r(j) >= zero) CYCLE
    tol = rerrmx*ABS(c(j))
    IF (ABS(r(j)) < tol) r(j) = zero
  END IF
END DO

IF (n0 == ns) GO TO 720
jmin = n0 + 1
DO j = jmin, ns
  IF (basis(j) /= 0) THEN
    r(j) = zero
  ELSE
    jj = j - n0
    r(j) = r(j) - const*bi(ip,jj)
  END IF
END DO

720 IF (ns == n) GO TO 200
jmin = ns + 1
DO j = jmin, n
  IF (basis(j) /= 0) THEN
    r(j) = zero
  ELSE
    jj = j - n0
    r(j) = r(j) + const*bi(ip,jj)
  END IF
END DO
GO TO 200
!-----------------------------------------------------------------------
!               REFINE XB AND STORE THE RESULT IN Y
!-----------------------------------------------------------------------
800 y(1:m) = zero

m0 = 0
DO j = 1, m
  kj = ibasis(j)
  IF (kj <= n0) GO TO 810
  IF (kj <= ns) GO TO 820
  IF (kj <= n) GO TO 830
  GO TO 820

  810 m0 = m0 + 1
  indx(m0) = j
  CYCLE

  820 l = kj - n0
  y(l) = xb(j)
  CYCLE

  830 l = kj - n0
  y(l) = -xb(j)
END DO

IF (m0 == 0) THEN
  r(1:m) = b0(1:m) - y(1:m)
ELSE
  DO i = 1, m
    dsum = y(i)
    DO jj = 1, m0
      j = indx(jj)
      kj = ibasis(j)
      dsum = dsum + a(i,kj)*xb(j)
    END DO
    r(i) = b0(i) - dsum
  END DO
END IF

rerr1 = MIN(rerrmx, rerr)
DO i = 1, m
  y(i) = zero
  IF (xb(i) < zero) THEN
    sgn = -1.0_dp
    dsump = zero
    dsumn = xb(i)
  ELSE IF (xb(i) > zero) THEN
    sgn = 1.0_dp
    dsump = xb(i)
    dsumn = zero
  ELSE
    CYCLE
  END IF
  DO l = 1, m
    dt = bi(i,l)*r(l)
    IF (dt > zero) THEN
      dsump = dsump + dt
    ELSE
      dsumn = dsumn + dt
    END IF
  END DO
  w = dsump + dsumn
  IF (w == zero) CYCLE
  IF (sgn /= SIGN(1.0_dp, w)) CYCLE
  s = dsump
  t = dsumn
  tol = rerr1*MAX(s, -t)
  IF (ABS(w) > tol) y(i) = w
END DO
IF (nstep == 2) GO TO 870
IF (nstep > 2) GO TO 880

!         CHECK THE REFINEMENT (NSTEP = 1)

DO i = 1, m
  IF (y(i) >= zero) GO TO 861
  IF (y(i) < -rerrmx) GO TO 240
  y(i) = zero
  861 xb(i) = y(i)
END DO
GO TO 630

!         CHECK THE REFINEMENT (NSTEP = 2)

870 DO i = 1, m
  IF (ibasis(i) <= n) GO TO 871
  IF (y(i) > rerrmx) GO TO 240
  y(i) = zero
  871 xb(i) = y(i)
END DO
GO TO 680

!              COMPUTE Z  (NSTEP = 3)

880 dsum = zero
DO i = 1, m
  ki = ibasis(i)
  IF (ki > n0) GO TO 881
  dsum = dsum + c(ki)*y(i)
  881 xb(i) = y(i)
END DO
z = dsum
GO TO 220
END SUBROUTINE smplx1

SUBROUTINE crout1(a, ka, n, iend, indx, temp, ierr)
!     ******************************************************************
!     CROUT PROCEDURE FOR INVERTING MATRICES
!     ******************************************************************
!     A IS A MATRIX OF ORDER N WHERE N IS GREATER THAN OR EQUAL TO 1.
!     THE INVERSE OF A IS COMPUTED AND STORED IN A.

!     KA = LENGTH OF THE COLUMNS OF THE ARRAY A

!     IEND MAY BE 0, 1, ..., N-1.  IT IS ASSUMED THAT EACH OF THE FIRST
!     IEND COLUMNS OF THE MATRIX A CONTAINS ONLY ONE NONZERO ELEMENT
!     AND THAT THE NONZERO ELEMENT IS 1 OR -1.

!     indx IS AN ARRAY OF DIMENSION N-1 OR LARGER THAT IS USED BY THE
!     ROUTINE FOR KEEPING TRACK OF THE ROW INTERCHANGES THAT ARE MADE.

!     TEMP IS A TEMPORARY STORAGE ARRAY.

!     IERR REPORTS THE STATUS OF THE RESULTS. IF A IS NONSINGULAR THEN
!     THE INVERSE OF A IS COMPUTED AND IERR=0. OTHERWISE IF A IS FOUND
!     TO BE SINGULAR THEN IERR=1 AND THE ROUTINE TERMINATES.
!     --------------------
USE constants_NSWC
IMPLICIT NONE
INTEGER, INTENT(IN)                     :: ka, n, iend
INTEGER, INTENT(OUT)                    :: ierr
REAL (dp), DIMENSION(:), INTENT(IN OUT) :: a, temp
INTEGER, DIMENSION(:), INTENT(IN OUT)   :: indx

!     Local variables
INTEGER   :: i, ibeg, ij, ik, il, j, jcol, jj, k, kcol, kcount, kj,  &
             kj0, kk, kl, km1, kp1, l, lj, lj0, lk, lmin, maxdim, mcol,  &
             ncol, nk, nm1, nmj, nmk, nn
REAL (dp) :: zero = 0._dp
REAL (dp) :: dsum, c, pmin, s

maxdim = ka*n
mcol = iend*ka
IF (iend == 0) GO TO 100

!           PROCESS THE FIRST IEND COLUMNS OF A

kcol = 0
DO k = 1, iend
  kk = kcol + k
  nk = kcol + n
  DO lk = kk, nk
    IF (a(lk) < zero) GO TO 20
    IF (a(lk) > zero) GO TO 30
  END DO
  GO TO 300

  20 l = lk - kcol
  lj0 = mcol + l
  DO lj = lj0, maxdim, ka
    a(lj) = -a(lj)
  END DO

  30 l = lk - kcol
  indx(k) = l
  IF (k == l) GO TO 32
  lj = lk
  DO kj = kk, maxdim, ka
    c = a(kj)
    a(kj) = a(lj)
    a(lj) = c
    lj = lj + ka
  END DO
  32 kcol = kcol + ka
END DO

!           PROCESS THE REMAINING COLUMNS OF A

100 nm1 = n - 1
ierr = 0
pmin = zero
ibeg = iend + 1
IF (ibeg == n) GO TO 190

k = ibeg
km1 = iend
kp1 = k + 1
kcol = mcol
kk = kcol + k
DO kcount = ibeg, nm1

!     SEARCH FOR THE K-TH PIVOT ELEMENT (K=IBEG, ..., N-1)

  l = k
  s = ABS(a(kk))
  DO i = kp1, n
    ik = kcol + i
    c = ABS(a(ik))
    IF (s >= c) CYCLE
    l = i
    s = c
  END DO

  IF (k > ibeg .AND. s >= pmin) GO TO 120
  pmin = s
  IF (s == zero) GO TO 300

!              INTERCHANGING ROWS K AND L

  120 indx(k) = l
  IF (k == l) GO TO 130
  kj0 = mcol + k
  lj  = mcol + l
  DO kj = kj0, maxdim, ka
    c = a(kj)
    a(kj) = a(lj)
    a(lj) = c
    lj = lj + ka
  END DO

!       COMPUTE THE K-TH ROW OF U (K=IBEG, ..., N-1)

  130 c = a(kk)
  IF (k > ibeg) GO TO 140
  kj0 = kk + ka
  DO kj = kj0, maxdim, ka
    a(kj) = a(kj)/c
  END DO
  GO TO 160

  140 kl = mcol + k
  DO l = ibeg, km1
    temp(l) = a(kl)
    kl = kl + ka
  END DO

  kj0 = kk + ka
  DO kj = kj0, maxdim, ka
    jcol = kj - k
    dsum = -a(kj)
    DO l = ibeg, km1
      lj = jcol + l
      dsum = dsum + temp(l)*a(lj)
    END DO
    a(kj) = -dsum/c
  END DO

!      COMPUTE THE K-TH COLUMN OF L (K=IBEG+1, ..., N)

  160 km1 = k
  k = kp1
  kp1 = k + 1
  kcol = kcol + ka
  kk = kcol + k
  DO l = ibeg, km1
    lk = kcol + l
    temp(l) = a(lk)
  END DO

  DO i = k, n
    il = mcol + i
    dsum = zero
    DO l = ibeg, km1
      dsum = dsum + a(il)*temp(l)
      il = il + ka
    END DO
    a(il) = a(il) - dsum
  END DO
END DO

!           CHECK THE N-TH PIVOT ELEMENT

190 ncol = maxdim - ka
nn = ncol + n
c = ABS(a(nn))
IF (c > pmin) GO TO 200
IF (c == zero) GO TO 300

!          REPLACE L WITH THE INVERSE OF L

200 IF (ibeg == n) GO TO 213
jj = mcol + ibeg
i = ka + 1
DO j = ibeg, nm1
  a(jj) = 1.0_dp/a(jj)
  temp(j) = a(jj)
  kj = jj
  DO km1 = j, nm1
    k = km1 + 1
    kj = kj + 1
    dsum = zero
    kl = kj
    DO l = j, km1
      dsum = dsum + a(kl)*temp(l)
      kl = kl + ka
    END DO
    a(kj) = -dsum/a(kl)
    temp(k) = a(kj)
  END DO
  jj = jj + i
END DO
213 a(nn) = 1.0_dp/a(nn)
IF (n == 1) RETURN

!       SOLVE UX = Y WHERE Y IS THE INVERSE OF L

DO nmk = 1, nm1
  k = n - nmk
  lmin = MAX(ibeg, k+1)
  kl = (lmin-1)*ka + k
  DO l = lmin, n
    temp(l) = a(kl)
    a(kl) = zero
    kl = kl + ka
  END DO

  kj0 = mcol + k
  DO kj = kj0, maxdim, ka
    dsum = -a(kj)
    lj = (kj - k) + lmin
    DO l = lmin, n
      dsum = dsum + temp(l)*a(lj)
      lj = lj + 1
    END DO
    a(kj) = -dsum
  END DO
END DO

!                 COLUMN INTERCHANGES

jcol = ncol - ka
DO nmj = 1, nm1
  j = n - nmj
  k = indx(j)
  IF (j == k) GO TO 251
  ij = jcol
  ik = (k-1)*ka
  DO i = 1, n
    ij = ij + 1
    ik = ik + 1
    c = a(ij)
    a(ij) = a(ik)
    a(ik) = c
  END DO
  251 jcol = jcol - ka
END DO
RETURN

!                    ERROR RETURN

300 ierr = 1
RETURN
END SUBROUTINE crout1


module mod_three
    implicit none
contains
    subroutine three(a,b,c,d)
    implicit none
	  REAL,INTENT(IN) :: a,b,c
	  REAL,INTENT(OUT) :: d

	  d = a/(b-c)

    end subroutine three
end module mod_three


  submodule (m_array1D) m_Array_id1D
    !! Routines for double precision integer arrays

  implicit none

  contains
  !====================================================================!
  module procedure arange_id1D
    !! Interfaced with [[arange]]
  !====================================================================!
  !module function arange_id1D(start,stp,_step) result(this)
  !integer(i64) :: start !! Start from here
  !integer(i64) :: stp !! Stop here
  !integer(i64) :: step !! Step size
  !integer(i64), allocatable :: res(:)
  integer(i64) :: i
  integer(i64) :: N
  integer(i64) :: step_
  step_ = 1
  if (present(step)) step_ = step
  N=((stp-start)/step_)+1
  if (size(res) /= N) call eMsg('arange_id1D:1D Array must be size '//str(N))
  if (step_ == 1) then
      do i = 1, N
          res(i) = start + i-1
      enddo
  else
      do i = 1, N
          res(i) = start + (i-1)*step_
      enddo
  endif
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure diff_id1D
    !! Interfaced [[diff]]
  !====================================================================!
!  integer(i64), intent(in) :: this(:) !! 1D array
!  integer(i64) :: res(size(this)-1) !! Difference along array
  integer(i32) :: i
  integer(i32) :: N
  N=size(this)
  if (size(res) /= N-1) call eMsg('diff_id1D:Result must be size '//str(N-1))
  do i=1,N-1
    res(i) = this(i+1) - this(i)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure isSorted_id1D
    !! Interfaced with [[isSorted]]
  !====================================================================!
  !module function isSorted_id1D(this) result(yes)
  !integer(i64):: this(:) !! 1D array
  !logical :: yes !! isSorted
  integer :: i,N
  N=size(this)
  yes=.true.
  do i=2,N
    if (this(i) < this(i-1)) then
      yes=.false.
      return
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure isSorted_id1Di1D
    !! Interfaced with [[isSorted]]
  !====================================================================!
  !module function isSorted_d1D(this) result(yes)
  !real(r64):: this(:) !! 1D array
  !integer(i32) :: indx(:)
  !logical :: yes !! isSorted
  integer :: i,N
  N=size(this)
  yes=.true.
  do i=2,N
    if (this(indx(i)) < this(indx(i-1))) then
      yes=.false.
      return
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure repeat_id1D
    !! Interfaced with [[repeat]]
  !====================================================================!
!  integer(i64) :: this(:) !! 1D array
!  integer(i32) :: nRepeats !! Number of times each element should be repeated
!  integer(i64) :: res(size(this)*nRepeats)
  integer(i32) :: i,k,N,nTmp
  N = size(this)
  nTmp = N*nRepeats
  call allocate(res, nTmp)
  !if (size(res) /= nTmp) call eMsg('repeat_d1D:Result must be size '//str(nTmp))
  k=1
  do i = 1, N
    res(k:k+nRepeats-1) = this(i) ! Repeat the element
    k = k + nRepeats
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure shuffle_id1D
    !! Interfaced with [[shuffle]]
  !====================================================================!
  !module subroutine shuffle_id1D(this)
  !integer(i64) :: this(:)
  integer(i32) :: i
  integer(i32) :: N
  integer(i32) :: r
  N=size(this)
  do i = 2, N
    call rngInteger(r, 1, i)
    call swap(this(i), this(r))
  end do
  end procedure
  !====================================================================!
end submodule


FUNCTION bandwidth(g) RESULT(nband)
! Used in p91, p101-p103, p112, p115, p810
! This function finds the element bandwidth from g.
!
 IMPLICIT NONE
 INTEGER,INTENT(IN)::g(:)
 INTEGER::nband
 nband=MAXVAL(g,1,g>0)-MINVAL(g,1,g>0)
RETURN
END FUNCTION bandwidth


      subroutine hrtmp(hour,halfdy)
c
c     +++PURPOSE+++
c     This function distributes the diurnal (daily) temperature
c     on an hourly basis.  The actual routine to do so was
c     written by DeWet, etal.,1978 and tested by Reicosky etal 1988.
c     DeWet was taken from "simulation of Simulation, Respiration,
c     and Transpiration" while Reicosky is from "Accuracy of
c     Hourly Air Temperatures Calculated from Daily Minima and Maxima.

c     Authors(s):  John Witte, UofMn WCES @ USDA-ARS-NCSRL
c     Date: 04/01/93

c     Verified and tested by Reza Savabi, USDA-ARS, NSERL 317-494-5051
c                  August 1994
c
c     +++ARGUMENT DECLARATIONS+++
      real    halfdy
      integer hour
c
c     +++ARGUMENT DEFINITIONS+++
c     halfdy - The amount of time from sunrise until noon (hrs).
c     hour   - The hour of the day that is currently being run.
c
c     + + + PARAMETERS + + +
c
      include 'pmxpln.inc'
      include 'pmxhil.inc'
c
c     +++COMMON BLOCKS+++
      include  'cclim.inc'
c       read:  tave,tmax,tmin,tdpt
c       modify: hrtemp,hrdewp
c
c     +++LOCAL VARIABLES+++
      save
      real    pi,adjhr,amp,sunris
c
c     +++LOCAL DEFINITIONS+++
c     pi     - Estimated value for 22/7.
c     adjhr  - Hour value adjustment made to deal with middle of hour.
c     amp    - The ampilitude of the temperature graph.
c     sunris - Hour of the day which sunrise occures (hr).
c
c     +++DATA INITIALIZATIONS+++
      data   pi/3.14159/
c
c     +++END SPECIFICATIONS+++

      sunris = 12.0 - halfdy
      tave = (tmax + tmin) / 2
      amp  = (tmax - tmin) / 2

      if ((hour .lt. sunris) .or. (14.0 .lt. hour)) then
        if (hour .lt. sunris) then
          adjhr = (hour - 0.5) + 10.0
        else
          adjhr = (hour - 0.5) - 14.0
        endif
cd    It is wrong to calculate dewpoint temperature this way!
cd    S. Dun, Aug 11, 2007
        hrtemp = tave + amp * (cos((pi * adjhr) / (10 + sunris)))
cd        hrdewp = tdpt + amp * (cos((pi * adjhr) / (10 + sunris)))
      else
        hrtemp = tave - amp * (cos(pi * (hour - 0.5 - sunris) /
     1            (14 - sunris)))
cd        hrdewp = tdpt - amp * (cos(pi * (hour - 0.5 - sunris) /
cd     1            (14 - sunris)))
      endif

      return
      end


c----------------------------------------------------------------
c----------------------------------------------------------------
c--- The chemical model example of daspk
c----------------------------------------------------------------
c----------------------------------------------------------------

c -------- daspkdll.f -> daspkdll.dll ------
c compile in R with: system("g77 -shared -o daspkfor.dll daspkfor.f")
c or with system("R CMD SHLIB daspkfor.f")

c----------------------------------------------------------------
c Initialiser for parameter common block
c----------------------------------------------------------------
      subroutine daspkfor(daspkparms)

      external daspkparms
      integer, parameter :: N = 4
      double precision parms(N)
      common /myparms/parms

      call daspkparms(N, parms)
      return
      end

c----------------------------------------------------------------
c residual of rate of change and 1 output variable
c----------------------------------------------------------------
      subroutine resfor (t, y, ydot, cj, delta, ires, out, ipar)
      integer            :: ires, ipar(*)
      integer, parameter :: neq = 3
      double precision   :: t, y(neq), ydot(neq), delta(neq), out(*)
      double precision   :: K, ka, r, prod, ra, rb
      common /myparms/K,ka,r,prod

      if(IPar(1) < 1) call rexit("nout should be at least 1")
      ra  = ka* y(3)            ! forward rate
      rb  = ka/K *y(1) * y(2)   ! backward rate

      ! residuals of rates of changes
      delta(3) = -ydot(3)  -  ra + rb + prod
      delta(1) = -ydot(1)  +  ra - rb
      delta(2) = -ydot(2)  +  ra - rb - r*y(2)
      out(1)   = y(1) + y(2) + y(3)
      return
      end

c----------------------------------------------------------------
c The jacobian matrix
c----------------------------------------------------------------
      subroutine resjacfor (t, y, dy, pd, cj, out, ipar)
      integer, parameter :: neq = 3
      integer            :: ipar(*)
      double precision   :: K, ka, r, prod
      double precision   :: pd(neq,neq),y(neq),dy(neq),out(*)
      common /myparms/K,ka,r,prod

      ! residuals of rates of changes
      !res1 = -dD  - ka*D + ka/K *A*B + prod
      PD(1,1) = ka/K *y(2)
      PD(1,2) = ka/K *y(1)
      PD(1,3) = -ka -cj
      !res2 = -dA  + ka*D - ka/K *A*B
      PD(2,1) = -ka/K *y(2) -cj
      PD(2,2) = -ka/K *y(2)
      PD(2,3) = ka
      !res3 = -dB  + ka*D - ka/K *A*B - r*B
      PD(3,1) = -ka/K *y(2)
      PD(3,2) = -ka/K *y(2) -r -cj
      PD(3,3) = ka

      return
      end


!!
!! Luke McCulloch
!! p1.f90
!! 6160 CFDpart1
!! 3-10-10
!! Simple program uses subroutines to read input file
!! (fifi.dat)
!! and store output in a seperate file  (out.dat)
!! The input file is fifi
!!
!!
!!
PROGRAM p2

  !! modules are program units that
  !! themselves contain variable declaerations
  !! and subroutines and functions.
  !! The contents of the module is made availbe
  !! in other program units
  !! with the USE statement

  use precise, only : defaultp  ! Double Precision
  use io                        ! Input Output (legacy really)
  use fifthpanel                ! Get the Panel Geometry vn, vt1, vt2
  use A                         ! Compute Dij coefficients in the "A" matrix
  use vtkxmlmod                 ! Create Paraview files
  use slae                      ! invert the Dij "A" matrix

!  USE fourthconst  ! incorporates everything from the module
!  USE thirdconst, ONLY : pi ! would only incorporate pi and ignore the rest
!  USE sphere ! a second module

!! variable declarations

  IMPLICIT NONE    ! makes sure the compiler complains about
                   ! undeclared variables
  integer, parameter :: WP=defaultp

  INTEGER :: narg      ! Integer variables
  INTEGER :: i, j, k, error
  INTEGER :: npoints, npanels
  INTEGER :: iounit

  CHARACTER(len=24) :: inputfile   ! file name can be max. 24 char. long
  CHARACTER(len=24) :: outputfile  ! file name can be max. 24 char. long
  CHARACTER(len=24) :: datafile1
  CHARACTER(len=24) :: datafile2
  CHARACTER(len=24) :: datafile3
  CHARACTER(len=30) :: title

  LOGICAL :: flexists  ! a logical variable. I .true. or .false.

  ! An allocatable array. Its actual size will be defined during
  ! execution of the program.
  ! The array has two dimensions (:,:), i.e. number of comma separated
  ! colons determines dimensions.
  INTEGER, ALLOCATABLE, DIMENSION(:,:) :: panels
  ! allocated in the io module
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: points
  !allocated in the io module

  ! Arrays for the fifth.f90 panel geometry property computations
  REAL(WP), DIMENSION(3,4) :: corners  ! temporary storage for panel corners
  REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: center
  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: coordsys
  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: cornerslocal
  REAL(wp), ALLOCATABLE, DIMENSION(:) :: area

  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: vel
  REAL(WP), DIMENSION(3) :: vp
  REAL(WP), DIMENSION(3) :: vpp
  REAL(WP), DIMENSION(3) :: vppp
  REAL(WP), DIMENSION(3) :: fieldpoint, fieldpointp, fieldpointpp
  REAL(WP), DIMENSION(3) :: fieldpointppp

  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: am
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: b
  REAL(WP), DIMENSION(3) :: vinf

  REAL(WP), ALLOCATABLE, DIMENSION(:) :: sigma
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: vtotal
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: vn
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: vt1
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: vt2
  REAL(WP), ALLOCATABLE, DIMENSION(:) :: cp

  REAL(WP),DIMENSION(1) :: force

  REAL(WP), DIMENSION(3) :: vtottest
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: velt
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: vtest
  REAL(WP), DIMENSION(3) :: testpoint
  REAL(WP), DIMENSION(3) :: vtp
  REAL(WP), DIMENSION(3) :: vtpp
  REAL(WP), DIMENSION(3) :: vtppp
  REAL(WP), DIMENSION(3) :: testpointp, testpointpp
  REAL(WP), DIMENSION(3) :: testpointppp
  REAL(WP), DIMENSION(1) :: cpt
  REAL(WP), DIMENSION(1) :: distance
  REAL(WP) :: testi, testj, testk

  integer :: switch

!  REAL(wp), ALLOCATABLE, DIMENSION(:) :: celldata1
!  REAL(wp), ALLOCATABLE, DIMENSION(:) :: celldata2
!  REAL(wp), DIMENSION(3) :: paneloffsets

  ! Variable declarations go before any executable statement

!! the actual program starts here

  ! Simple start up message
  ! The character A is used for formating character constants and
  ! variables
  WRITE(6,'(A)') 'HW1, v @.0, 2-20-10, Main Program, Luke McCulloch '

  ! Count the number command line arguments (actually Fortran 2003)
  ! If your compiler does not support this Fortran 2003 feature look
  ! for the common extension iargc()
  ! narg = iargc()
  narg = command_argument_count()
  WRITE(6, FMT='(AI3A)') 'we have ', narg, ' command line arguments '

  ! Now read the name of the input file and output file from the command line

  IF ( narg > 1 ) THEN
     ! If there are 2 (or more) arguments we will retrieve them

     ! We use the first argument as name for the input file to
     ! the program
     CALL get_command_argument(1, inputfile)

     ! We use the second argument as name for the output file to
     ! the program
     CALL get_command_argument(2, outputfile)

  ELSE
     ! Only 1 or no arguments have been provided on the command
     ! line. Report the error and print a simple help.
     WRITE(6,'(A)') ' Output file name and/or sphere diameter missing!'
     WRITE(6,'(A)') ' Usage:>  third <outputfile> <diameter> <nl> <ng>'
     ! Of course <inputfile> and <outputfile> have to be replaced
     ! with file names and not typed literally
     STOP ! abort program
  ENDIF

  INQUIRE(file=inputfile, exist=flexists)

  IF (flexists) THEN

     !Here are two different ways to write the output to the screen.
     WRITE(6,'(AA)') ' input file,  ', inputfile
     WRITE(6,*) 'output file, ', outputfile

!! Call a subroutine to read the input file back into the main program
!! This is from the "io" MODULE
!! ALLOCATE 2 ARRAYS : "points" and "panels"
!!
!! and output the input file into the out.dat file as a check.
!!----------------------------------------------------------------------
     CALL input( inputfile, outputfile, title, &
                         npanels, npoints, &
                         panels, points,i,j)
!!----------------------------------------------------------------------

  Else
     ! If not, the program stops
     WRITE(6,'(A)') ' Input file does not exist!'
     STOP ! abort program
  ENDIF

  ! We read fifi in the "input" subroutine
  ! Write fifi to the screen
  ! write(6,'(A)') title
  write(6,*) title
  write(6,*) i,j
  write(6,*) npanels, npoints
  write(6,'(4I4)') panels
  write(6,'(3D16.8)') points

!
!
!!
!!--------------------------------------------------------------------
!!--------------------------------------------------------------------
!!  compute panel properties as in fifth.f90

 ALLOCATE( center(3,npanels) )
 ALLOCATE( coordsys(3,3,npanels) )
 ALLOCATE( cornerslocal(2,4,npanels) )
 ALLOCATE( area(npanels) )

  DO i = 1, npanels
 !    WRITE(6,'(A)') 'Panel point numbers:'
 !    WRITE(6,'(4I6)') (panels(j,i), j=1,4)

 !    WRITE(6,'(A)') 'Panel point coordinates:'
 !    DO j = 1, 4
 !       WRITE(6,'(I5'': ''3(G12.6,2X))') panels(j,i), &
 !            (points(k,panels(j,i)), k = 1,3)
 !    END DO
 !
 !    ! we store the panel corner points in a 3 by 4 array
     DO j=1, 4
        corners(:,j) = points(:,panels(j,i))
     END DO

     ! We call the panel geometry function IN THE  MODULE "fifthpanel"
     ! Output data is collected in arrays with additional dimension
     ! for number of panels
     CALL panelgeometry( corners, coordsys(:,:,i), cornerslocal(:,:,i), &
                      area(i), center(:,i) )

     ! We pick some output to check.
     !WRITE(6,'(''nv: '',3(G12.6,2X))') coordsys(:,3,i)
     !WRITE(6,'(''cl: '',8(G12.6,2X))') cornerslocal(:,:,i)
     !WRITE(6,'(''A: '',G12.6)') area(i)
     !WRITE(6,'(''center: '',3(G12.6,2X))') center(:,i)

  END DO

!! end of fifth.f90 computations
!!--------------------------------------------------------------------

!! Compute the A matrix
!!---------------------------------------------------------------------
!!---------------------------------------------------------------------
    !!
    !! procedure to compute the A matrix of v dot a
    !!
    !! Input:  the locations of panel centers pi and qj
    !!         the normal vector of each panel center
    !!         the area of each panel
    !!
    !!
    !!
    !! Output:  the velocity at panel i induced by panel j
    !!          the A matrix
    !!
    !!
    !!
    !! Note we will use the following  from fifthpanel Output:
    !!     coordsys: a 3x3 matrix containing the two tangent vectors
    !!               and the normal vector
    !!                  t1x   t2x   nx
    !!                  t1y   t2y   ny
    !!                  t1z   t2z   nz
    !!               i.e. coordsys(:,3) is the normal vector
    !!     area: the area of the panel
    !!     center: the 3D coordinates of the panel center
    !!

  !! Allocate needed memory
  ALLOCATE(vel(3,npanels,npanels))
  ALLOCATE(am(npanels,npanels))
  ALLOCATE(b(npanels))
  ALLOCATE(sigma(npanels))

  ALLOCATE(vtotal(3,npanels))
  ALLOCATE(vn(npanels))
  ALLOCATE(vt1(npanels))
  ALLOCATE(vt2(npanels))
  ALLOCATE(cp(npanels))

  !!  Double Do Loop to compute the A matrix

    !! First get the image system of mirrored points
    !! in lieu of mirroring panels
    DO i=1,npanels

       fieldpoint(:)=center(:,i)

!       !! First mirror the fieldpoints about the Z-X plane
       fieldpointp(:)=fieldpoint(:)
       fieldpointp(2)=-fieldpoint(2)
!
!       ! Now mirror original fieldpoints about the Y-X plane
       fieldpointpp(:)=fieldpoint(:)
       fieldpointpp(3)=-fieldpointpp(3)
!
!       ! Now mirror the first mirrored fieldpoints about the Y-X plane
       fieldpointppp(:)=fieldpointp(:)
       fieldpointppp(3)=-fieldpointppp(3)
!
!
!
!       !! Compute the velocities
       Do j=1,npanels
!
!
!          !First get the singular points
          IF(i==j)THEN
             vel(:,i,j)=-0.5*coordsys(:,3,i)
!
!          !Then get the nonsingular points
          ELSE
             vel(:,i,j)=panelinfluence(fieldpoint(:),center(:,j),area(j),coordsys(:,:,j),cornerslocal(:,:,j))
          END IF

          !Now get the influence of the panel
          !on the mirrored points
          vp(:)=panelinfluence(fieldpointp(:),center(:,j),area(j),coordsys(:,:,j),cornerslocal(:,:,j))
          vpp(:)=panelinfluence(fieldpointpp(:),center(:,j),area(j),coordsys(:,:,j),cornerslocal(:,:,j))
          vppp(:)=panelinfluence(fieldpointppp(:),center(:,j),area(j),coordsys(:,:,j),cornerslocal(:,:,j))
!

          !Get Influence of panel sj
          !and its mirrors @ point pi

          !Use no mirrors if modeling the whole sphere.

          !Velocities for the quarter body (in "double body" flow)
          vel(1,i,j) = vel(1,i,j)+vp(1)+vpp(1)+vppp(1)
          vel(2,i,j) = vel(2,i,j)-vp(2)+vpp(2)-vppp(2)
          vel(3,i,j) = vel(3,i,j)+vp(3)-vpp(3)-vppp(3)

          !Finally, make the a(i,j) matrix
          am(i,j)= DOT_PRODUCT(coordsys(:,3,i),vel(:,i,j))

       END DO

    END DO

!  write(6,*) 'the velocity on each panel center'
!  write(6,'(3D16.8)') vel
!  write(6,*)''
!  write(6,*) 'the a matrix'
!  write(6,'(6D16.8)') am
!  write(6,*)''

!!  End of a(i,j) matrix computations
!!---------------------------------------------------------------------

!!---------------------------------------------------------------------
!!  Compute the RHS

  !!  Define Vinfinity
  vinf = (/1.,0.,0./) !re-write using U= Fr*sqrt(length*g), V=0, W=0

  DO i=1, npanels

     b(i)= DOT_PRODUCT(coordsys(:,3,i),vinf)  !From MODULE "SLAE"

  END DO

!!  RHS done
!!---------------------------------------------------------------------

  !!  Invert the a matrix and solve for the Source Strength
  call gauss(am, b, sigma, error)

  !!Evaluate Flow Properties
  Do i=1,npanels
     vtotal(:,i) = -vinf(:)
     Do j=1, npanels
        vtotal(:,i)=vtotal(:,i)+sigma(j)*vel(:,i,j)
     End Do

     !! Get the NORMAL VELOCITY on each panel:
     vn(i)=Dot_Product(coordsys(:,3,i),vtotal(:,i))
     !Should be 0 for all panels

     !write(6,*) vn

     !! Get the tangent components on a panel
     vt1(i)=dot_product(coordsys(:,1,i),vtotal(:,i))
     vt2(i)=dot_product(coordsys(:,2,i),vtotal(:,i))

     ! Get the pressure on each panel from the steady Bernoulli Eq
     cp(i)=1.-sum(vtotal(:,i)**2)/sum(vinf**2)

  !write(6,*) 'the normal velocity on each panel'
  !write(6,'(1D16.8)') vn
!  write(6,*)''
!  write(6,*) 'cp', cp

  force(:)=0.
  force(:)=force(:)+cp(i)*area(i)*coordsys(:,3,i)&
          *.5*1000.*sum(vinf**2)

  end do
  write(6,*) 'force', force
! Write a seperate loop to compute vtotals and cp's at field points specified by you!
! 1st, an Example: For the point (5,0,0) find the velocity induced by the sphere.
!!  Test - input the "test point" from the dos prompt.

ALLOCATE(vtest(3,npanels))
ALLOCATE(velt(3,npanels))

1 Write(6,*) 'Enter "1" if you would like to choose a test point '
Write(6,*) 'Enter "0" if you would like to end the program '
read(*,*) switch

IF(switch==1)Then

Write(6,*) 'choose test point i value'
read(*,*) testi
Write(6,*) 'choose test point j value'
read(*,*) testj
Write(6,*) 'choose test point k  value'
read(*,*) testk

       testpoint = (/ testi, testj, testk /)
       !testpoint=center(:,1)-.001*coordsys(:,3,i)
       !! First mirror the fieldpoints about the Z-X plane
       testpointp(:)=testpoint(:)
       testpointp(2)=-testpoint(2)

       ! Now mirror original fieldpoints about the Y-X plane
       testpointpp(:)=testpoint(:)
       testpointpp(3)=-testpointpp(3)

       ! Now mirror the first mirrored fieldpoints about the Y-X plane
       testpointppp(:)=testpointp(:)
       testpointppp(3)=-testpointppp(3)

     vtottest=-vinf
     Do j=1, npanels

        distance = sqrt(sum((testpoint(:)-center(:,j))**2.))

        !First get the singular points---------------------------------
        IF(abs(distance(1))<.0000001)THEN
             vtest(:,j)=-0.5*coordsys(:,3,i)

        !Then get the nonsingular points
        ELSE

        vtest(:,j) = panelinfluence(testpoint(:),center(:,j),area(j),coordsys(:,:,j),cornerslocal(:,:,j))

        End if

        !Now get the influence of the panel
        !on the mirrored points
        vtp(:)=panelinfluence(testpointp(:),center(:,j),area(j),coordsys(:,:,j),cornerslocal(:,:,j))
        vtpp(:)=panelinfluence(testpointpp(:),center(:,j),area(j),coordsys(:,:,j),cornerslocal(:,:,j))
        vtppp(:)=panelinfluence(testpointppp(:),center(:,j),area(j),coordsys(:,:,j),cornerslocal(:,:,j))

        !Velocities for the quarter body (in "double body" flow)
        velt(1,j) = vtest(1,j)+vtp(1)+vtpp(1)+vtppp(1)
        velt(2,j) = vtest(2,j)-vtp(2)+vtpp(2)-vtppp(2)
        velt(3,j) = vtest(3,j)+vtp(3)-vtpp(3)-vtppp(3)

         vtottest(:)=vtottest(:)+sigma(j)*velt(:,j)
         cpt=1.-(sum(vtottest(:)**2))/(sum(vinf**2))
!        vtottest(:)=vinf(:)+sigma(j)*vtest(:,j)
!        vtottest= vtottest(:)+vtest(:,j)
!        cpt=1.-((sum(vtottest(:)**2))/(sum(vinf**2)))

     end do

  write(6,*) 'v test'
  write(6,'(3D16.8)') vtottest
   write(6,*) 'cpt', cpt

GO TO 1

Else

End If

  !! Lets try to store the cp's on each panel...
  !!***************************************************************

    ! First we store data valid for a panel (cell in VTK jargon)

  ! Create a file name with the appropriate extension
   i = INDEX(outputfile, ".", BACK=.TRUE.)
   IF (i == 0) THEN
      WRITE(datafile1, '(A,A,A)')  TRIM(outputfile), 'scalar', '.vtp'
   ELSE
      IF (i > 20) i = 20 ! To make sure the filename does not exceed 24 char
      WRITE(datafile1, '(A,A,A)')  outputfile(1:i-1), 'scalar', '.vtp'
   ENDIF
   PRINT*, datafile1

   iounit = 10
   CALL VtkXmlPolyDataCellScalar( iounit, datafile1, npoints, &
         0, 0, 0, npanels, &
         RESHAPE(points, (/3*npoints/)), &
         RESHAPE((panels-1), (/4*npanels/)), &
         scalar1=cp, &
         scalar2=sigma, &
         namescalar1='cp', &
         namescalar2='sigma')

  !!******************************************************************

  !! Now the total velocity vector on each panel...
  !!***************************************************************
   ! Create a file name with the appropriate extension
  i = INDEX(outputfile, ".", BACK=.TRUE.)
  IF (i == 0) THEN
     WRITE(datafile2, '(A,A,A)')  TRIM(outputfile), 'vtotal', '.vtp'
  ELSE
     IF (i > 20) i = 20 ! To make sure the filename does not exceed 24 char
     WRITE(datafile2, '(A,A,A)')  outputfile(1:i-1), 'vtotal', '.vtp'
  ENDIF
  PRINT*, datafile2

  iounit = 10
  CALL VtkXmlSaveVectorFlowData( iounit, datafile2, npanels, center, &
        vtotal)

! This method probably won't work for later versions of the program!

! vt1 and vt2 must be re-converted into vectors to display as vectors
! multiply coordsys()times the scalar vt1 or vt2 to scale the coordsys
! vector.  Then they should work.

  !!******************************************************************

  !! Now the vector data on each panel...
  !!***************************************************************
   ! Create a file name with the appropriate extension
  i = INDEX(outputfile, ".", BACK=.TRUE.)
  IF (i == 0) THEN
     WRITE(datafile3, '(A,A,A)')  TRIM(outputfile), 'components', '.vtp'
  ELSE
     IF (i > 20) i = 20 ! To make sure the filename does not exceed 24 char
     WRITE(datafile3, '(A,A,A)')  outputfile(1:i-1), 'components', '.vtp'
  ENDIF
  PRINT*, datafile3

  iounit = 10
  CALL VtkXmlPolyDataCellScalar( iounit, datafile3, npoints, &
        0, 0, 0, npanels, &
        RESHAPE(points, (/3*npoints/)), &
        RESHAPE((panels-1), (/4*npanels/)), &
        scalar1=vn, &
        scalar2=vt1, &
        scalar3=vt2, &
        namescalar1='vn', &
        namescalar2='vt1', &
        namescalar3='vt2')

! Face specific
! Scalar components of the velocity vector
! correct format
  !!******************************************************************

  ! De-allocate all arrays
  IF (ALLOCATED(points)) DEALLOCATE(points)
  IF (ALLOCATED(panels)) DEALLOCATE(panels)

  IF (ALLOCATED(center)) DEALLOCATE(center)
  IF (ALLOCATED(coordsys)) DEALLOCATE(coordsys)
  IF (ALLOCATED(cornerslocal)) DEALLOCATE(cornerslocal)
  IF (ALLOCATED(area)) DEALLOCATE(area)

  IF (ALLOCATED(vel)) DEALLOCATE(vel)
  IF (ALLOCATED(am)) DEALLOCATE(am)
  IF (ALLOCATED(b)) DEALLOCATE(b)

  IF (ALLOCATED(sigma)) DEALLOCATE(sigma)

  IF (ALLOCATED(vtotal)) DEALLOCATE(vtotal)
  IF (ALLOCATED(vn)) DEALLOCATE(vn)
  IF (ALLOCATED(vt1)) DEALLOCATE(vt1)
  IF (ALLOCATED(vt2)) DEALLOCATE(vt2)
  IF (ALLOCATED(cp)) DEALLOCATE(cp)
  IF (ALLOCATED(vtest)) DEALLOCATE(vtest)
  IF (ALLOCATED(velt)) DEALLOCATE(velt)

!  IF (ALLOCATED(celldata1)) DEALLOCATE(celldata1)
!  IF (ALLOCATED(celldata2)) DEALLOCATE(celldata2)

  ! Every program ends with end program
END PROGRAM p2
! end of file