module fqs_vector

    use fqs_types,       only: wp
    use fqs_quaternion,  only: quat_t

    implicit none
    private

    type, public :: vect_t
        real(wp) :: x = 0.0_wp
        real(wp) :: y = 0.0_wp
        real(wp) :: z = 0.0_wp
    contains
        generic, public :: operator(+) => add
        generic, public :: operator(-) => sub
        generic, public :: operator(*) => mul_left
        generic, public :: operator(*) => mul_right
        generic, public :: operator(/) => divide_by_scalar

        procedure, pass(self) :: add
        procedure, pass(self) :: sub
        procedure, pass(self) :: mul_left
        procedure, pass(self) :: mul_right
        procedure, pass(self) :: divide_by_scalar

        procedure, pass(self) :: norm => normal
        procedure, pass(self) :: sum2 => sum_of_squares
        procedure, pass(self) :: to_array => to_array
    end type vect_t

    type(vect_t), parameter :: e1 = vect_t(1.0_wp, 0.0_wp, 0.0_wp)
    type(vect_t), parameter :: e2 = vect_t(0.0_wp, 1.0_wp, 0.0_wp)
    type(vect_t), parameter :: e3 = vect_t(0.0_wp, 0.0_wp, 1.0_wp)

    interface vect_t
        procedure :: new_from_values
    end interface vect_t

    interface vect_to_array
        procedure :: single_vect_to_array
        procedure :: array_1d_of_vect_to_array
        procedure :: array_2d_of_vect_to_array
    end interface vect_to_array

    public e1, e2, e3
    public vect_dot, vect_cross, vect_to_array, basis_vect

contains

    ! vect_t constructors
    ! -------------------------------------------------------------------------

    elemental function new_from_values(x,y,z) result(v)
        real(wp), intent(in) :: x, y, z
        type(vect_t)         :: v
        v % x = x
        v % y = y
        v % z = z
    end function new_from_values

    ! vect_t methods
    ! -------------------------------------------------------------------------

    elemental function add(self,v) result(w)
        class(vect_t), intent(in) :: self
        type(vect_t),  intent(in) :: v
        type(vect_t)              :: w
        w % x = self % x + v % x
        w % y = self % y + v % y
        w % z = self % z + v % z
    end function add

    elemental function sub(self,v) result(w)
        class(vect_t), intent(in) :: self
        type(vect_t),  intent(in) :: v
        type(vect_t)              :: w
        w % x = self % x - v % x
        w % y = self % y - v % y
        w % z = self % z - v % z
    end function sub

    elemental function mul_left(scalar,self) result(w)
        class(vect_t), intent(in) :: self
        real(wp),      intent(in) :: scalar
        type(vect_t)              :: w
        w % x = scalar * (self % x)
        w % y = scalar * (self % y)
        w % z = scalar * (self % z)
    end function mul_left

    elemental function mul_right(self,scalar) result(w)
        class(vect_t), intent(in) :: self
        real(wp),      intent(in) :: scalar
        type(vect_t)              :: w
        w % x = scalar * (self % x)
        w % y = scalar * (self % y)
        w % z = scalar * (self % z)
    end function mul_right

    elemental function divide_by_scalar(self,scalar) result(v)
        class(vect_t), intent(in) :: self
        real(wp), intent(in)      :: scalar
        type(vect_t) :: v
        v%x = self%x / scalar
        v%y = self%y / scalar
        v%z = self%z / scalar
    end function divide_by_scalar

    elemental function normal(self) result(norm)
        class(vect_t), intent(in) :: self
        real(wp)                  :: norm
        norm = sqrt( self % sum2() )
    end function normal

    elemental function sum_of_squares(self) result(sum2)
        class(vect_t), intent(in) :: self
        real(wp)                  :: sum2
        sum2 = (self % x)**2 + (self % y)**2 + (self % z)**2
    end function sum_of_squares

    function to_array(self) result(a)
        class(vect_t), intent(in) :: self
        real(wp)                  :: a(3)
        a(1) = self % x
        a(2) = self % y
        a(3) = self % z
    end function to_array

    ! utility functions
    ! ---------------------------------------------------------------------------

    elemental function vect_dot(v,w) result(val)
        ! Computes the dot product of vectors v and w
        type(vect_t), intent(in) :: v
        type(vect_t), intent(in) :: w
        real(wp)                 :: val
        val = (v % x)*(w % x) + (v % y)*(w % y) + (v % z)*(w % z)
    end function vect_dot

    elemental function vect_cross(v,w) result(u)
        ! Computes the cross product of vectors v and w
        type(vect_t), intent(in) :: v
        type(vect_t), intent(in) :: w
        type(vect_t)             :: u
        u % x = ((v % y) * (w % z)) - ((v % z)*(w % y))
        u % y = ((v % z) * (w % x)) - ((v % x)*(w % z))
        u % z = ((v % x) * (w % y)) - ((v % y)*(w % x))
    end function vect_cross

    function single_vect_to_array(v) result(a)
        type(vect_t), intent(in) :: v
        real(wp)                 :: a(3)
        a = v % to_array()
    end function single_vect_to_array

    function array_1d_of_vect_to_array(v) result(a)
        type(vect_t), intent(in) :: v(:)
        real(wp)                 :: a(size(v),3)
        integer                  :: i
        do i=1,size(v)
            a(i,:) = v(i) % to_array()
        end do
    end function array_1d_of_vect_to_array

    function array_2d_of_vect_to_array(v) result(a)
        type(vect_t), intent(in) :: v(:,:)
        real(wp)                 :: a(size(v,1),size(v,2),3)
        integer                  :: i,j
        do i=1,size(v,1)
            do j=1,size(v,2)
                a(i,j,:) = v(i,j) % to_array()
            end do
        end do
    end function array_2d_of_vect_to_array

    elemental function basis_vect(ind) result(v)
        integer, intent(in) :: ind
        type(vect_t)        :: v

        if ((ind > 3) .or. (ind < 0)) then
            error stop 'ind must be 1,2,3'
        end if

        select case(ind)
            case (1)
                v % x = 1.0_wp
            case (2)
                v % y = 1.0_wp
            case (3)
                v % z = 1.0_wp
        end select
    end function basis_vect

end module fqs_vector


      subroutine spli2d ( tau, gtau, t, n, k, m, work, q, bcoef, iflag )
c  from  * a practical guide to splines *  by c. de boor
calls bsplvb, banfac/slv
c  this is an extended version of  splint , for the use in tensor prod-
c  uct interpolation.
c
c   spli2d  produces the b-spline coeff.s  bcoef(j,.)  of the spline of
c   order  k  with knots  t (i), i=1,..., n + k , which takes on the
c   value  gtau (i,j)  at  tau (i), i=1,..., n , j=1,..., m .
c
c******  i n p u t  ******
c  tau.....array of length  n , containing data point abscissae.
c    a s s u m p t i o n . . .	tau  is strictly increasing
c  gtau(.,j)..corresponding array of length  n , containing data point
c	 ordinates, j=1,...,m
c  t.....knot sequence, of length  n+k
c  n.....number of data points and dimension of spline space  s(k,t)
c  k.....order of spline
c  m.....number of data sets
c
c******  w o r k   a r e a  ******
c  work  a vector of length  n
c
c******  o u t p u t  ******
c  q.....array of size	(2*k-1)*n , containing the triangular factoriz-

c	 ation of the coefficient matrix of the linear system for the b-
c	 coefficients of the spline interpolant.
c	    the b-coeffs for the interpolant of an additional data set
c	 (tau(i),htau(i)), i=1,...,n  with the same data abscissae can
c	 be obtained without going through all the calculations in this

c	 routine, simply by loading  htau  into  bcoef	and then execut-
c	 ing the    call banslv ( q, 2*k-1, n, k-1, k-1, bcoef )
c  bcoef.....the b-coefficients of the interpolant, of length  n
c  iflag.....an integer indicating success (= 1)  or failure (= 2)
c	 the linear system to be solved is (theoretically) invertible if
c	 and only if
c	       t(i) .lt. tau(i) .lt. tau(i+k),	  all i.
c	 violation of this condition is certain to lead to  iflag = 2 .

c
c******  m e t h o d  ******
c     the i-th equation of the linear system  a*bcoef = b  for the b-co-
c  effs of the interpolant enforces interpolation at  tau(i), i=1,...,n.
c  hence,  b(i) = gtau(i), all i, and  a  is a band matrix with  2k-1
c   bands (if it is invertible).
c     the matrix  a  is generated row by row and stored, diagonal by di-
c  agonal, in the  r o w s  of the array  q , with the main diagonal go-
c  ing into row  k .  see comments in the program below.
c     the banded system is then solved by a call to  banfac (which con-

c  structs the triangular factorization for  a	and stores it again in
c   q ), followed by a call to	banslv (which then obtains the solution

c   bcoef  by substitution).
c     banfac  does no pivoting, since the total positivity of the matrix
c  a  makes this unnecessary.
c
      integer iflag,k,m,n,   i,ilp1mx,j,jj,km1,kpkm2,left,lenq,np1
      real bcoef(m,n),gtau(n,m),q(1),t(1),tau(n),work(n),   taui
c     dimension q(2*k-1,n), t(n+k)
current fortran standard makes it impossible to specify precisely the
c  dimension of  q  and  t  without the introduction of otherwise super-
c  fluous additional arguments.
      np1 = n + 1
      km1 = k - 1
      kpkm2 = 2*km1
      left = k
c		 zero out all entries of q
      lenq = n*(k+km1)
      do 5 i=1,lenq
    5	 q(i) = 0.
c
c  ***	 loop over i to construct the  n  interpolation equations
      do 30 i=1,n
	 taui = tau(i)
	 ilp1mx = min0(i+k,np1)
c	 *** find  left  in the closed interval (i,i+k-1) such that
c		 t(left) .le. tau(i) .lt. t(left+1)
c	 matrix is singular if this is not possible
	 left = max0(left,i)
	 if (taui .lt. t(left)) 	go to 998
   15	    if (taui .lt. t(left+1))	go to 16
	    left = left + 1
	    if (left .lt. ilp1mx)	go to 15
	 left = left - 1
	 if (taui .gt. t(left+1))	go to 998
c	 *** the i-th equation enforces interpolation at taui, hence
c	 a(i,j) = b(j,k,t)(taui), all j. only the  k  entries with  j =

c	 left-k+1,...,left actually might be nonzero. these  k	numbers

c	 are returned, in  work  (used for temp.storage here), by the
c	 following
   16	 call bsplvb ( t, k, 1, taui, left, work )
c	 we therefore want  work(j) = b(left -k+j)(taui) to go into
c	 a(i,left-k+j), i.e., into  q(i-(left+j)+2*k,(left+j)-k) since
c	 a(i+j,j)  is to go into  q(i+k,j), all i,j,  if we consider  q

c	 as a two-dim. array , with  2*k-1  rows (see comments in
c	 banfac). in the present program, we treat  q  as an equivalent

c	 one-dimensional array (because of fortran restrictions on
c	 dimension statements) . we therefore want  work(j) to go into
c	 entry
c	     i -(left+j) + 2*k + ((left+j) - k-1)*(2*k-1)
c		    =  i-left+1 + (left -k)*(2*k-1) + (2*k-2)*j
c	 of  q .
	 jj = i-left+1 + (left-k)*(k+km1)
	 do 30 j=1,k
	    jj = jj+kpkm2
   30	    q(jj) = work(j)
c
c     ***obtain factorization of  a  , stored again in	q.
      call banfac ( q, k+km1, n, km1, km1, iflag )
					go to (40,999), iflag
c     *** solve  a*bcoef = gtau  by backsubstitution
   40 do 50 j=1,m
	 do 41 i=1,n
   41	    work(i) = gtau(i,j)
	 call banslv ( q, k+km1, n, km1, km1, work )
	 do 50 i=1,n
   50	    bcoef(j,i) = work(i)
					return
  998 iflag = 2
  999 print 699
  699 format(41h linear system in  splint  not invertible)
					return
      end


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

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

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

      DOUBLE PRECISION :: v0, v1, v2, v3, y5, y6, y7, y8
      DOUBLE PRECISION :: A, B, G, aa, bb, gg, sigm, taua, taub, taug
      DOUBLE PRECISION :: m, C, C1, C2, C3, C4, C5, C6, C7

      ! VARIABLES

      v3 = U(1)
      v0 = U(2)
      v1 = U(3)
      v2 = U(4)

      y8 = U(5)
      y5 = U(6)
      y6 = U(7)
      y7 = U(8)

      ! PARAMETERS
      A = PAR(1)
      B = PAR(2)
      G = PAR(3)
      aa = PAR(4)
      bb = PAR(5)
      gg = PAR(6)
      m = PAR(7)
      C = PAR(8)
      C1 = PAR(9)
      C2 = PAR(10)
      C3 = PAR(12)
      C4 = PAR(13)
      C5 = PAR(14)
      C6 = PAR(15)
      C7 = PAR(16)

      taua=1/aa
      taub=1/bb
      taug=1/gg

      ! RIGHT-HAND SIDE

      F(1) = y8
      F(2) = y5*(taug/taua)
      F(3)= y6*(taug/taua)
      F(4)= y7*(taug/taub)

      F(5) = (G*sigm(c5*taua*y0-c6*taub*y2)- 2*y8- v3)
      F(6) = (A*sigm(m*A*taua+c2*taua*y1 - c4*taub*y2 -c7*taug*y3)- 2*y5- v0)*(taug/taua)
      F(7) = (A*sigm(c1*taua*y0)-2*y6- v1)*(taug/taua)
      F(8) = (B*sigm(c3*taua*y0) -2*y7- v2)*(taug/taub)

      END SUBROUTINE FUNC
!----------------------------------------------------------------------

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

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

      ! VARIABLES
      U(1) = 0.0 !v3
      U(2) = 0.150158 !v0
      U(3) = 0.9363391 !v1
      U(4) = 6.90745 !v2
      U(5) = 0.0d0 !y5
      U(6) = 0.0d0 !y6
      U(7) = 0.0d0 !y8
      U(8) = 0.0d0 !y9

      ! PARAMETERS
      PAR(1) = 5 !A
      PAR(2) = 40 !B
      PAR(3) = 35 !G
      PAR(4) = 100 !aa
      PAR(5) = 20 !bb
      PAR(6) = 350 !gg
      PAR(7) = 90 !m
      PAR(8) = 135 !C
      PAR(9) = 135 !C1
      PAR(10) = 108 !C2
      PAR(12) = 35 !C3
      PAR(13) = 25 !C4
      PAR(14) = 450 !C5
      PAR(15) = 121  !C6
      PAR(16) = 121 !C7

      END SUBROUTINE STPNT
!----------------------------------------------------------------------

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS

!----------------------------------------------------------------------
      FUNCTION sigm(x)
!----------------------------------------
! Function for integration
!----------------------------------------
      IMPLICIT NONE
      DOUBLE PRECISION :: sigm, x
      sigm = 5/(1 + exp(0.56*(6-x)))
      RETURN
      END FUNCTION sigm


c subroutine lfp (init,n,m,l,cp,pb,w)
c
c dimension of           cp((n/2)+1), pb(l), w(5*l+41)
c arguments
c
c purpose                routine lfp uses coefficients computed by
c                        routine alfk to calculate the single precision
c                        normalized associated legendre function pbar(n,
c                        m,theta) at colatitudes theta=(i-1)*pi/(l-1),
c                        i=1,...,l. subroutine lfp evaluates pbar
c                        using one of the following trigonometric
c                        expansions
c
c                        1) for n even and m even, pbar(m,n,theta) =
c                           .5*cp(1) plus the sum from k=1 to k=n/2
c                           of cp(k)*cos(2*k*th)
c
c                        2) for n even and m odd, pbar(m,n,theta) =
c                           the sum from k=1 to k=n/2 of
c                           cp(k)*sin(2*k*th)
c
c                        3) for n odd and m even, pbar(m,n,theta) =
c                           the sum from k=1 to k=(n+1)/2 of
c                           cp(k)*cos((2*k-1)*th)
c
c                        4) for n odd and m odd,  pbar(m,n,theta) =
c                           the sum from k=1 to k=(n+1)/2 of
c                           cp(k)*sin((2*k-1)*th)
c
c
c usage                  call lfp(init,n,m,l,cp,pb,w)
c
c arguments
c
c on input               init
c                          = 0 initialization only
c                          = 1 compute pbar(n,m,theta)
c
c                          lfp call with init = 0 initializes array w;
c                          no values of pbar(n,m,theta) are computed.
c                          init=0 should be used on the first call, or
c                          if l or w values differ from those in the
c                          previous call.
c
c                        n
c                          nonnegative integer, less than l, specifying
c                          the degree of pbar(n,m,theta)
c
c                        m
c                          is the order of pbar(n,m,theta). m can be
c                          any integer however pbar(n,m,theta) = 0
c                          if abs(m) is greater than n and
c                          pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta)
c                          for negative m.
c
c                        l
c                          number of colatitudes theta=(i-1)*pi/(l-1)
c                          for i=1,...,l where l is greater than 1.
c                          l must be an odd integer.
c
c                        cp
c                          single precision array of length (n/2)+1
c                          containing coefficients computed by routine
c                          alfk
c
c                        w
c                          a single precision work array with at
c                          least 5*l+41 locations
c
c on output              pb
c                          single precision array of length l containing
c                          pbar(n,m,theta), theta=(i-1)*pi/(l-1) for i=1
c                          ,...,l.
c
c                        w
c                          a single precision array containing values
c                          which must not be destroyed if the next call
c                          will have the same value of input parameter n
c
c special conditions     calls to routine lfp must be preceded by an
c                        appropriate call to routine alfk.
c
c precision              single
c
c algorithm              the trigonometric series formula used by
c                        routine lfp to calculate pbar(n,m,theta) for
c                        theta=(i-1)*pi/(l-1), i=1,...,n, depends on
c                        m and n as follows:
c
c                           1) for n even and m even, the formula is
c                              .5*cp(1) plus the sum from k=1 to k=n/2
c                              of cp(k)*cos(2*k*theta)
c                           2) for n even and m odd. the formula is
c                              the sum from k=1 to k=n/2 of
c                              cp(k)*sin(2*k*theta)
c                           3) for n odd and m even, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*cos((2*k-1)*theta)
c                           4) for n odd and m odd, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*sin((2*k-1)*theta)
c
c accuracy               comparison between routines lfp and double
c                        precision dlfp on the cray1 indicates greater
c                        accuracy for smaller values of input parameter
c                        n.  agreement to 12 places was obtained for
c                        n=10 and to 11 places for n=100.
c
c timing                 time per call to routine lfp is dependent on
c                        the input parameters l and n.
c
      SUBROUTINE DLFP(INIT,N,M,L,CP,PB,W)
      DOUBLE PRECISION CP
      DOUBLE PRECISION PB
      DOUBLE PRECISION W
      DIMENSION CP(1),PB(1),W(1)
c
      DO 10 I = 1,L
          PB(I) = 0.D0
   10 CONTINUE
      MA = IABS(M)
      IF (MA.GT.N) RETURN
      IW1 = L + L + 12
      IW2 = IW1 + 3* (L+1)/2 + 15
      CALL DLFP1(INIT,N,MA,L,CP,PB,W,W(IW1),W(IW2))
      RETURN
      END
      SUBROUTINE DLFP1(INIT,N,M,L,CP,P,WSAVE1,WSAVE2,WSAVE3)
      DOUBLE PRECISION CP
      DOUBLE PRECISION P
      DOUBLE PRECISION WSAVE1
      DOUBLE PRECISION WSAVE2
      DOUBLE PRECISION WSAVE3
      DOUBLE PRECISION SSQRT2
      DOUBLE PRECISION PI
      DOUBLE PRECISION DT
      DIMENSION CP(1),P(1),WSAVE1(1),WSAVE2(1),WSAVE3(1)
      SAVE LC,LQ,LS

      IF (INIT.NE.0) GO TO 41
      LC = (L+1)/2
      LS = LC - 2
      LQ = LC - 1
      CALL SINTI(LS,WSAVE1)
      CALL COSTI(LC,WSAVE2)
      CALL COSQI(LQ,WSAVE3)
      RETURN
   41 IF (N) 10,10,40
   10 IF (M) 20,20,40
   20 SSQRT2 = 1.D0/SQRT(2.D0)
      DO 30 I = 1,L
          P(I) = SSQRT2
   30 CONTINUE
      RETURN
   40 LS2 = (L+1)/2
      LM1 = L - 1
      NP1 = N + 1
      PI = 4.D0*ATAN(1.D0)
      DT = PI/LM1
      NMOD = MOD(N,2)
      MMOD = MOD(M,2)
      IF (NMOD) 50,50,120
   50 IF (MMOD) 60,60,90
   60 KDP = N/2 + 1
      DO 70 I = 1,KDP
          P(I) = .5D0*CP(I)
   70 CONTINUE
      P(LC) = P(LC) + P(LC)
      CALL COST(LC,P,WSAVE2)
      DO 80 I = 1,LC
          LMI = L - I
          P(LMI+1) = P(I)
   80 CONTINUE
      GO TO 190
   90 KDP = N/2
      DO 100 I = 1,KDP
          P(I+1) = .5D0*CP(I)
  100 CONTINUE
      P(LS+2) = 0.D0
      CALL SINT(LS,P(2),WSAVE1)
      DO 110 I = 1,LS
          LMI = L - I
          P(LMI) = -P(I+1)
  110 CONTINUE
      P(L) = 0.D0
      GO TO 190
  120 KDP = (N+1)/2
      IF (MMOD) 140,140,160
  140 DO 130 I = 1,KDP
          P(I) = .25D0*CP(I)
  130 CONTINUE
      CALL COSQB(LQ,P,WSAVE3)
      DO 150 I = 1,LQ
          LMI = L - I
          P(LMI+1) = -P(I)
  150 CONTINUE
      GO TO 190
  160 DO 180 I = 1,KDP
          P(I+1) = .25D0*CP(I)
  180 CONTINUE
      CALL SINQB(LQ,P(2),WSAVE3)
      DO 170 I = 1,LQ
          LMI = L - I
          P(LMI) = P(I+1)
  170 CONTINUE
      P(L) = 0.D0
  190 RETURN
      END


subroutine smoothww(nx,ny,p,wl,nitr,mx)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    smoothww    smooth two dimensional field
!   prgmmr: derber           org: np22                date: 2004-05-13
!
! abstract: This routine smooths a two dimensional field
!
! program history log:
!   2004-05-13  derber, document
!   2010-10-08  derber - optimize and clean up
!
!   input argument list:
!     nx   - first dimension of two dimensional array
!     ny   - second dimension of two dimensional array
!     p    - nx by ny array (field) to be smoothed (filtered)
!     wl   - smoothing coefficient
!     nitr - number of smoother passes
!     mx   - smoothing coefficient multiplier
!
!   output argument list
!     p    - smoothed (filtered) two dimensional array
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind
  use constants, only: one,two
  implicit none

  integer(i_kind),intent(in   ) :: nx,ny,nitr,mx
  real(r_kind)   ,intent(in   ) :: wl
  real(r_kind)   ,intent(inout) :: p(nx,ny)

  integer(i_kind) nx1,nx2,ny1,ny2,n
  integer(i_kind) im,jm,jp,j,ip,i

  real(r_kind) hwl,hwl2,hwlx

! Initialize local variables
  hwl=wl/nitr
  hwl2=hwl/((hwl+one)+sqrt(hwl*two+one))
  hwl=hwl*mx
  hwlx=hwl/((hwl+one)+sqrt(hwl*two+one))
  hwl=hwl2

! Big loop over number of smoother passes
  do n=1,nitr

!    Smooth in 2d over all y (second dimension)
     ny1=1
     ny2=ny

!    Adjoint(?) of forward pass
     nx1=1
     nx2=nx-1
     do j=ny1,ny2
        do i=nx1,nx2
           p(i,j)=(one-hwlx)*p(i,j)
        enddo
     enddo
     do i=nx2,nx1,-1
        ip=i+1
        do j=ny1,ny2
           p(i,j)=p(i,j)+hwlx*p(ip,j)
        enddo
     enddo

!    Adjoint(?) of backward pass
     nx1=2
     nx2=nx
     do j=ny1,ny2
        do i=nx1,nx2
           p(i,j)=(one-hwlx)*p(i,j)
        enddo
     enddo
     do i=nx1,nx2
        im=i-1
        do j=ny1,ny2
           p(i,j)=p(i,j)+hwlx*p(im,j)
        enddo
     enddo

!    Backward pass
     nx1=1
     nx2=nx-1
     do i=nx2,nx1,-1
        ip=i+1
        do j=ny1,ny2
           p(i,j)=p(i,j)+hwlx*(p(ip,j)-p(i,j))
        enddo
     enddo

!    Forward pass
     nx1=2
     nx2=nx
     do i=nx1,nx2
        im=i-1
        do j=ny1,ny2
           p(i,j)=p(i,j)+hwlx*(p(im,j)-p(i,j))
        enddo
     enddo

!    Smooth in 2d over all x (first dimension)
     nx1=1
     nx2=nx

!    Adjoint(?) of forward pass
     ny1=1
     ny2=ny-1
     do j=ny1,ny2
        do i=nx1,nx2
           p(i,j)=(one-hwl)*p(i,j)
        enddo
     enddo
     do j=ny2,ny1,-1
        jp=j+1
        do i=nx1,nx2
           p(i,j)=p(i,j)+hwl*p(i,jp)
        enddo
     enddo

!    Adjoint(?) of backward pass
     ny1=2
     ny2=1+ny
     do j=ny1,ny2
        do i=nx1,nx2
           p(i,j)=(one-hwl)*p(i,j)
        enddo
     enddo
     do j=ny1,ny2
        jm=j-1
        do i=nx1,nx2
           p(i,j)=p(i,j)+hwl*p(i,jm)
        enddo
     enddo

!    Backward pass
     ny1=1
     ny2=ny-1
     do j=ny2,ny1,-1
        jp=j+1
        do i=nx1,nx2
           p(i,j)=p(i,j)+hwl*(p(i,jp)-p(i,j))
        enddo
     enddo

!    Forward pass
     ny1=2
     ny2=ny
     do j=ny1,ny2
        jm=j-1
        do i=nx1,nx2
           p(i,j)=p(i,j)+hwl*(p(i,jm)-p(i,j))
        enddo
     enddo

  enddo

  return
end subroutine smoothww


!=============================================================================!
        subroutine cgrad2(ndof, nx, ny, v, g1v, g11v, g12v, g22v, dx, dy, &
                          optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)
!
!  Take the second derivative of a complex 2-D field.
!  Updated to sixth-order accurate differencing on the interior with
!  the option for optimized fourth-order differencing.
!
!  Added g1v as input to improve efficiency
!
!  Revised: 4-17-96
!=============================================================================!
        use stencil
        implicit none

        integer :: ndof, nx, ny, optx, opty
        logical :: xper, yper
        logical :: lsym, rsym, bsym, tsym, carp
        complex :: v(ny,nx,ndof), g1v(ny,nx,ndof)
        complex :: g11v(ny,nx,ndof), g12v(ny,nx,ndof), g22v(ny,nx,ndof)
        real    :: dx, dy

        real, parameter :: zero = 0.0, one = 1.0, pt5 = 0.5, two = 2.0
        real :: dxinv, dyinv, dxsinv, dysinv
        real :: a, b, c, w
        real :: gx1, gx2, gx3, gx4, gx5, gx6
        real :: gy1, gy2, gy3, gy4, gy5, gy6
        real :: dx1, dx2, dx3, dx4, dx5, dx6, dx7
        real :: dy1, dy2, dy3, dy4, dy5, dy6, dy7

        integer :: i, j, idof
        real :: eps = 1.0e-12, isign
!=============================================================================!
        dxinv  = one / dx
        dyinv  = one / dy
        dxsinv = one / dx**2
        dysinv = one / dy**2

!.... seven point stencil in x

        if (optx.eq.0) then
          c = 1.0 / 60.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gx1 =  -c * dxinv
        gx2 =  -b * dxinv
        gx3 =  -a * dxinv
        gx4 =   a * dxinv
        gx5 =   b * dxinv
        gx6 =   c * dxinv

        if (optx.eq.0) then
          c = 1.0 / 90.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = -(3.0*w**2 - 16.0*Sin(w/2.0)**2 + Sin(w)**2) / &
               (12.0*(-15.0*Sin(w/2.0)**2 + 6.0*Sin(w)**2 -  &
               Sin(3.0*w/2.0)**2))
        end if

        a = (4.0 + 45.0 * c) / 3.0
        b = -(1.0 + 72.0 * c) / 12.0

        dx1 =  c * dxsinv
        dx2 =  b * dxsinv
        dx3 =  a * dxsinv
        dx4 = -2.0 * ( a + b + c ) * dxsinv
        dx5 =  a * dxsinv
        dx6 =  b * dxsinv
        dx7 =  c * dxsinv

!.... seven point stencil in y

        if (opty.eq.0) then
          c = 1.0 / 60.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gy1 =  -c * dyinv
        gy2 =  -b * dyinv
        gy3 =  -a * dyinv
        gy4 =   a * dyinv
        gy5 =   b * dyinv
        gy6 =   c * dyinv

        if (opty.eq.0) then
          c = 1.0 / 90.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = -(3.0*w**2 - 16.0*Sin(w/2.0)**2 + Sin(w)**2) / &
               (12.0*(-15.0*Sin(w/2.0)**2 + 6.0*Sin(w)**2 -  &
               Sin(3.0*w/2.0)**2))
        end if

        a = (4.0 + 45.0 * c) / 3.0
        b = -(1.0 + 72.0 * c) / 12.0

        dy1 =  c * dysinv
        dy2 =  b * dysinv
        dy3 =  a * dysinv
        dy4 = -2.0 * ( a + b + c ) * dysinv
        dy5 =  a * dysinv
        dy6 =  b * dysinv
        dy7 =  c * dysinv

!=============================================================================!
!.... compute the second derivative in x
!=============================================================================!

        if (xper) then

          g11v(:,1,:)       = ( dx1 * v(:,nx-3,:)   + &
                                dx2 * v(:,nx-2,:)   + &
                                dx3 * v(:,nx-1,:)   + &
                                dx4 * v(:,1,:)      + &
                                dx5 * v(:,2,:)      + &
                                dx6 * v(:,3,:)      + &
                                dx7 * v(:,4,:)      )

          g11v(:,2,:)       = ( dx1 * v(:,nx-2,:)   + &
                                dx2 * v(:,nx-1,:)   + &
                                dx3 * v(:,1,:)      + &
                                dx4 * v(:,2,:)      + &
                                dx5 * v(:,3,:)      + &
                                dx6 * v(:,4,:)      + &
                                dx7 * v(:,5,:)      )

          g11v(:,3,:)       = ( dx1 * v(:,nx-1,:)   + &
                                dx2 * v(:,1,:)      + &
                                dx3 * v(:,2,:)      + &
                                dx4 * v(:,3,:)      + &
                                dx5 * v(:,4,:)      + &
                                dx6 * v(:,5,:)      + &
                                dx7 * v(:,6,:)      )

          g11v(:,nx-2,:)    = ( dx1 * v(:,nx-5,:)   + &
                                dx2 * v(:,nx-4,:)   + &
                                dx3 * v(:,nx-3,:)   + &
                                dx4 * v(:,nx-2,:)   + &
                                dx5 * v(:,nx-1,:)   + &
                                dx6 * v(:,1,:)      + &
                                dx7 * v(:,2,:)      )

          g11v(:,nx-1,:)    = ( dx1 * v(:,nx-4,:)   + &
                                dx2 * v(:,nx-3,:)   + &
                                dx3 * v(:,nx-2,:)   + &
                                dx4 * v(:,nx-1,:)   + &
                                dx5 * v(:,1,:)      + &
                                dx6 * v(:,2,:)      + &
                                dx7 * v(:,3,:)   )

          g11v(:,nx,:) = g11v(:,1,:)

        else

          g11v(:,1,:)       = ( dd1 * v(:,1,:) + &
                                dd2 * v(:,2,:) + &
                                dd3 * v(:,3,:) + &
                                dd4 * v(:,4,:) + &
                                dd5 * v(:,5,:) ) * dxsinv

          g11v(:,2,:)       = ( db1 * v(:,1,:) + &
                                db2 * v(:,2,:) + &
                                db3 * v(:,3,:) + &
                                db4 * v(:,4,:) + &
                                db5 * v(:,5,:) ) * dxsinv

          g11v(:,3,:)       = ( da1 * v(:,1,:) + &
                                da2 * v(:,2,:) + &
                                da3 * v(:,3,:) + &
                                da4 * v(:,4,:) + &
                                da5 * v(:,5,:) ) * dxsinv

          g11v(:,nx-2,:)    = ( da1 * v(:,nx-4,:) + &
                                da2 * v(:,nx-3,:) + &
                                da3 * v(:,nx-2,:) + &
                                da4 * v(:,nx-1,:) + &
                                da5 * v(:,nx,:)   ) * dxsinv

          g11v(:,nx-1,:)    =   ( db1 * v(:,nx,:)   + &
                                  db2 * v(:,nx-1,:) + &
                                  db3 * v(:,nx-2,:) + &
                                  db4 * v(:,nx-3,:) + &
                                  db5 * v(:,nx-4,:) ) * dxsinv

          g11v(:,nx,:)      =   ( dd1 * v(:,nx,:)   + &
                                  dd2 * v(:,nx-1,:) + &
                                  dd3 * v(:,nx-2,:) + &
                                  dd4 * v(:,nx-3,:) + &
                                  dd5 * v(:,nx-4,:) ) * dxsinv

        end if

!.... implement symmetry conditions

        if (lsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

            g11v(:,1,idof)    = ( isign * dx1 * v(:,4,idof)     + &
                                  isign * dx2 * v(:,3,idof)     + &
                                  isign * dx3 * v(:,2,idof)     + &
                                  dx4 * v(:,1,idof)             + &
                                  dx5 * v(:,2,idof)             + &
                                  dx6 * v(:,3,idof)             + &
                                  dx7 * v(:,4,idof)             )

            g11v(:,2,idof)    = ( isign * dx1 * v(:,3,idof)     + &
                                  isign * dx2 * v(:,2,idof)     + &
                                  dx3 * v(:,1,idof)             + &
                                  dx4 * v(:,2,idof)             + &
                                  dx5 * v(:,3,idof)             + &
                                  dx6 * v(:,4,idof)             + &
                                  dx7 * v(:,5,idof)             )

            g11v(:,3,idof)    = ( isign * dx1 * v(:,2,idof)     + &
                                  dx2 * v(:,1,idof)             + &
                                  dx3 * v(:,2,idof)             + &
                                  dx4 * v(:,3,idof)             + &
                                  dx5 * v(:,4,idof)             + &
                                  dx6 * v(:,5,idof)             + &
                                  dx7 * v(:,6,idof)             )
          end do
        end if

        if (rsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

            g11v(:,nx-2,idof) = ( dx1 * v(:,nx-5,idof)          + &
                                  dx2 * v(:,nx-4,idof)          + &
                                  dx3 * v(:,nx-3,idof)          + &
                                  dx4 * v(:,nx-2,idof)          + &
                                  dx5 * v(:,nx-1,idof)          + &
                                  dx6 * v(:,nx,idof)            + &
                                  isign * dx7 * v(:,nx-1,idof)  )

            g11v(:,nx-1,idof) = ( dx1 * v(:,nx-4,idof)          + &
                                  dx2 * v(:,nx-3,idof)          + &
                                  dx3 * v(:,nx-2,idof)          + &
                                  dx4 * v(:,nx-1,idof)          + &
                                  dx5 * v(:,nx,idof)            + &
                                  isign * dx6 * v(:,nx-1,idof)  + &
                                  isign * dx7 * v(:,nx-2,idof)  )

            g11v(:,nx,idof)   = ( dx1 * v(:,nx-3,idof)          + &
                                  dx2 * v(:,nx-2,idof)          + &
                                  dx3 * v(:,nx-1,idof)          + &
                                  dx4 * v(:,nx,idof)            + &
                                  isign * dx5 * v(:,nx-1,idof)  + &
                                  isign * dx6 * v(:,nx-2,idof)  + &
                                  isign * dx7 * v(:,nx-3,idof)  )
          end do
        end if

!.... interior

        g11v(:,4:nx-3,:) = ( dx1 * v(:,1:nx-6,:)   + &
                             dx2 * v(:,2:nx-5,:)   + &
                             dx3 * v(:,3:nx-4,:)   + &
                             dx4 * v(:,4:nx-3,:)   + &
                             dx5 * v(:,5:nx-2,:)   + &
                             dx6 * v(:,6:nx-1,:)   + &
                             dx7 * v(:,7:nx  ,:)   )

!=============================================================================!
!.... compute the second derivative in y
!=============================================================================!

        if (yper) then

          g22v(1,:,:)       = ( dy1 * v(ny-3,:,:)   + &
                                dy2 * v(ny-2,:,:)   + &
                                dy3 * v(ny-1,:,:)   + &
                                dy4 * v(1,:,:)      + &
                                dy5 * v(2,:,:)      + &
                                dy6 * v(3,:,:)      + &
                                dy7 * v(4,:,:)      )

          g22v(2,:,:)       = ( dy1 * v(ny-2,:,:)   + &
                                dy2 * v(ny-1,:,:)   + &
                                dy3 * v(1,:,:)      + &
                                dy4 * v(2,:,:)      + &
                                dy5 * v(3,:,:)      + &
                                dy6 * v(4,:,:)      + &
                                dy7 * v(5,:,:)      )

          g22v(3,:,:)       = ( dy1 * v(ny-1,:,:)   + &
                                dy2 * v(1,:,:)      + &
                                dy3 * v(2,:,:)      + &
                                dy4 * v(3,:,:)      + &
                                dy5 * v(4,:,:)      + &
                                dy6 * v(5,:,:)      + &
                                dy7 * v(6,:,:)      )

          g22v(ny-2,:,:)    = ( dy1 * v(ny-5,:,:)   + &
                                dy2 * v(ny-4,:,:)   + &
                                dy3 * v(ny-3,:,:)   + &
                                dy4 * v(ny-2,:,:)   + &
                                dy5 * v(ny-1,:,:)   + &
                                dy6 * v(1,:,:)      + &
                                dy7 * v(2,:,:)      )

          g22v(ny-1,:,:)    = ( dy1 * v(ny-4,:,:)   + &
                                dy2 * v(ny-3,:,:)   + &
                                dy3 * v(ny-2,:,:)   + &
                                dy4 * v(ny-1,:,:)   + &
                                dy5 * v(1,:,:)      + &
                                dy6 * v(2,:,:)      + &
                                dy7 * v(3,:,:)   )

          g22v(ny,:,:) = g22v(1,:,:)

        else

          g22v(1,:,:)      =  ( dd1 * v(1,:,:) + &
                                dd2 * v(2,:,:) + &
                                dd3 * v(3,:,:) + &
                                dd4 * v(4,:,:) + &
                                dd5 * v(5,:,:) ) * dysinv

          g22v(2,:,:)      =  ( db1 * v(1,:,:) + &
                                db2 * v(2,:,:) + &
                                db3 * v(3,:,:) + &
                                db4 * v(4,:,:) + &
                                db5 * v(5,:,:) ) * dysinv

          g22v(3,:,:)       = ( da1 * v(1,:,:) + &
                                da2 * v(2,:,:) + &
                                da3 * v(3,:,:) + &
                                da4 * v(4,:,:) + &
                                da5 * v(5,:,:) ) * dysinv

          g22v(ny-2,:,:)    = ( da1 * v(ny-4,:,:) + &
                                da2 * v(ny-3,:,:) + &
                                da3 * v(ny-2,:,:) + &
                                da4 * v(ny-1,:,:) + &
                                da5 * v(ny,:,:)   ) * dysinv

          g22v(ny-1,:,:)   =  ( db1 * v(ny,:,:)   + &
                                db2 * v(ny-1,:,:) + &
                                db3 * v(ny-2,:,:) + &
                                db4 * v(ny-3,:,:) + &
                                db5 * v(ny-4,:,:) ) * dysinv

          g22v(ny,:,:)     =  ( dd1 * v(ny,:,:)   + &
                                dd2 * v(ny-1,:,:) + &
                                dd3 * v(ny-2,:,:) + &
                                dd4 * v(ny-3,:,:) + &
                                dd5 * v(ny-4,:,:) ) * dysinv

        endif

!.... interior

        g22v(4:ny-3,:,:) = ( dy1 * v(1:ny-6,:,:)   + &
                             dy2 * v(2:ny-5,:,:)   + &
                             dy3 * v(3:ny-4,:,:)   + &
                             dy4 * v(4:ny-3,:,:)   + &
                             dy5 * v(5:ny-2,:,:)   + &
                             dy6 * v(6:ny-1,:,:)   + &
                             dy7 * v(7:ny  ,:,:)   )

!=============================================================================!
!.... compute the cross derivative
!=============================================================================!

        if (yper) then

          g12v(1,:,:)       = ( gy1 * g1v(ny-3,:,:)     + &
                                gy2 * g1v(ny-2,:,:)     + &
                                gy3 * g1v(ny-1,:,:)     + &
                                gy4 * g1v(2,:,:)        + &
                                gy5 * g1v(3,:,:)        + &
                                gy6 * g1v(4,:,:)        )

          g12v(2,:,:)       = ( gy1 * g1v(ny-2,:,:)     + &
                                gy2 * g1v(ny-1,:,:)     + &
                                gy3 * g1v(1,:,:)        + &
                                gy4 * g1v(3,:,:)        + &
                                gy5 * g1v(4,:,:)        + &
                                gy6 * g1v(5,:,:)        )

          g12v(3,:,:)       = ( gy1 * g1v(ny-1,:,:)     + &
                                gy2 * g1v(1,:,:)        + &
                                gy3 * g1v(2,:,:)        + &
                                gy4 * g1v(4,:,:)        + &
                                gy5 * g1v(5,:,:)        + &
                                gy6 * g1v(6,:,:)        )

          g12v(ny-2,:,:)    = ( gy1 * g1v(ny-5,:,:)     + &
                                gy2 * g1v(ny-4,:,:)     + &
                                gy3 * g1v(ny-3,:,:)     + &
                                gy4 * g1v(ny-1,:,:)     + &
                                gy5 * g1v(1,:,:)        + &
                                gy6 * g1v(2,:,:)        )

          g12v(ny-1,:,:)    = ( gy1 * g1v(ny-4,:,:)     + &
                                gy2 * g1v(ny-3,:,:)     + &
                                gy3 * g1v(ny-2,:,:)     + &
                                gy4 * g1v(1,:,:)        + &
                                gy5 * g1v(2,:,:)        + &
                                gy6 * g1v(3,:,:)        )

          g12v(ny,:,:) = g12v(1,:,:)

        else

          g12v(1,:,:)     = ( gc1 * g1v(1,:,:)  + &
                              gc2 * g1v(2,:,:)  + &
                              gc3 * g1v(3,:,:)  + &
                              gc4 * g1v(4,:,:)  + &
                              gc5 * g1v(5,:,:)  ) * dyinv

          g12v(2,:,:)     = ( gb1 * g1v(1,:,:)  + &
                              gb2 * g1v(2,:,:)  + &
                              gb3 * g1v(3,:,:)  + &
                              gb4 * g1v(4,:,:)  + &
                              gb5 * g1v(5,:,:)  ) * dyinv

          g12v(3,:,:)     = ( ga1 * g1v(1,:,:)  + &
                              ga2 * g1v(2,:,:)  + &
                              ga3 * g1v(4,:,:)  + &
                              ga4 * g1v(5,:,:)  ) * dyinv

          g12v(ny-2,:,:)  = ( ga1 * g1v(ny-4,:,:)  + &
                              ga2 * g1v(ny-3,:,:)  + &
                              ga3 * g1v(ny-1,:,:)  + &
                              ga4 * g1v(ny  ,:,:)  ) * dyinv

          g12v(ny-1,:,:) = -( gb1 * g1v(ny  ,:,:)  + &
                              gb2 * g1v(ny-1,:,:)  + &
                              gb3 * g1v(ny-2,:,:)  + &
                              gb4 * g1v(ny-3,:,:)  + &
                              gb5 * g1v(ny-4,:,:)  ) * dyinv

          g12v(ny,:,:)   = -( gc1 * g1v(ny  ,:,:)  + &
                              gc2 * g1v(ny-1,:,:)  + &
                              gc3 * g1v(ny-2,:,:)  + &
                              gc4 * g1v(ny-3,:,:)  + &
                              gc5 * g1v(ny-4,:,:)  ) * dyinv

        end if

!.... interior

        g12v(4:ny-3,:,:) = ( gy1 * g1v(1:ny-6,:,:)      + &
                             gy2 * g1v(2:ny-5,:,:)      + &
                             gy3 * g1v(3:ny-4,:,:)      + &
                             gy4 * g1v(5:ny-2,:,:)      + &
                             gy5 * g1v(6:ny-1,:,:)      + &
                             gy6 * g1v(7:ny  ,:,:)      )

!.... Implement Carpenter's boundary stencil on the wall

        if (carp .and. (.not. yper) ) then
          g12v(1,:,:)    = ( gg1 * g1v(1,:,:)   + &
                             gg2 * g1v(2,:,:)   + &
                             gg3 * g1v(3,:,:)   + &
                             gg4 * g1v(4,:,:)   + &
                             gg5 * g1v(5,:,:)   + &
                             gg6 * g1v(6,:,:)  ) * dyinv

          g12v(2,:,:)    = ( gh1 * g1v(1,:,:)   + &
                             gh2 * g1v(2,:,:)   + &
                             gh3 * g1v(3,:,:)   + &
                             gh4 * g1v(4,:,:)   + &
                             gh5 * g1v(5,:,:)   + &
                             gh6 * g1v(6,:,:)  ) * dyinv

          g12v(3,:,:)    = ( gi1 * g1v(1,:,:)   + &
                             gi2 * g1v(2,:,:)   + &
                             gi3 * g1v(3,:,:)   + &
                             gi4 * g1v(4,:,:)   + &
                             gi5 * g1v(5,:,:)   + &
                             gi6 * g1v(6,:,:)  ) * dyinv

          g12v(4,:,:)    = ( gj1 * g1v(1,:,:)   + &
                             gj2 * g1v(2,:,:)   + &
                             gj3 * g1v(3,:,:)   + &
                             gj4 * g1v(4,:,:)   + &
                             gj5 * g1v(5,:,:)   + &
                             gj6 * g1v(6,:,:)  ) * dyinv

          g12v(ny-3,:,:) =-( gj1 * g1v(ny,:,:)    + &
                             gj2 * g1v(ny-1,:,:)  + &
                             gj3 * g1v(ny-2,:,:)  + &
                             gj4 * g1v(ny-3,:,:)  + &
                             gj5 * g1v(ny-4,:,:)  + &
                             gj6 * g1v(ny-5,:,:)  ) * dyinv

          g12v(ny-2,:,:) =-( gi1 * g1v(ny,:,:)    + &
                             gi2 * g1v(ny-1,:,:)  + &
                             gi3 * g1v(ny-2,:,:)  + &
                             gi4 * g1v(ny-3,:,:)  + &
                             gi5 * g1v(ny-4,:,:)  + &
                             gi6 * g1v(ny-5,:,:)  ) * dyinv

          g12v(ny-1,:,:) =-( gh1 * g1v(ny,:,:)    + &
                             gh2 * g1v(ny-1,:,:)  + &
                             gh3 * g1v(ny-2,:,:)  + &
                             gh4 * g1v(ny-3,:,:)  + &
                             gh5 * g1v(ny-4,:,:)  + &
                             gh6 * g1v(ny-5,:,:)  ) * dyinv

          g12v(ny,:,:)   =-( gg1 * g1v(ny,:,:)    + &
                             gg2 * g1v(ny-1,:,:)  + &
                             gg3 * g1v(ny-2,:,:)  + &
                             gg4 * g1v(ny-3,:,:)  + &
                             gg5 * g1v(ny-4,:,:)  + &
                             gg6 * g1v(ny-5,:,:)  ) * dyinv
        end if

!.... implement a filter of roundoff noise

!       do idof = 1, ndof
!         do i = 1, nx
!           do j = 1, ny
!             if ( abs(g11v(j,i,idof)) .lt. eps ) g11v(j,i,idof) = zero
!             if ( abs(g12v(j,i,idof)) .lt. eps ) g12v(j,i,idof) = zero
!             if ( abs(g22v(j,i,idof)) .lt. eps ) g22v(j,i,idof) = zero
!           end do
!         end do
!       end do

        return
        end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Copyright 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,  Washington University,
c Mallinckrodt Institute of Radiology. All Rights Reserved.
c This software may not be reproduced, copied, or distributed without written
c permission of Washington University. For further information contact A. Z. Snyder.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c $Header: /data/petsun4/data1/src_solaris/librms/RCS/gauss3d.f,v 1.2 2000/12/13 18:44:47 avi Exp $
c $Log: gauss3d.f,v $
c Revision 1.2  2000/12/13  18:44:47  avi
c copyright
c
c Revision 1.1  1996/04/19  17:09:18  ty7777
c Initial revision
c
      subroutine GAUSS3D (image, nx, ny, nz, cmppix, fhalf)
c     3D Gaussian filter
c     Author: Avi Snyder 05-Jan-93
c
c     inputs: real*4 image(nx,ny,nz)    ! image to be filtered
c             real*4 cmppix(3)          ! x, y, z voxel dimensions in cm
c             real*4 fhalf              ! half amplitude frequency in cycles/cm
c
c     variables modified: image         ! input image overwritten
c
c     subroutines called:  FFT, REALT in FORTRAN source fftsun.f
c                          FFT algorithm by Richard C. Singleton via FFTPE.FTN
c
c     restrictions: mixed radix FFT accepts any nx, ny, nz but
c                   nx must be divisible by 2
c                   memory allocation requirement 8*(nx/2+1)*ny*nz bytes

      real*4 image(nx,ny,nz)
      real*4 cmppix(3)
      pointer (pa,a),(pb,b)
      real*4 a((nx/2+1)*ny*nz),b((nx/2+1)*ny*nz)

      pa=malloc(4*(nx/2+1)*ny*nz)
      pb=malloc(4*(nx/2+1)*ny*nz)

      i=1
      do 21 iz=1,nz
      do 21 iy=1,ny
      do 21 ix=1,nx,2
      a(i)=image(ix,iy,iz)
      b(i)=image(ix+1,iy,iz)
   21 i=i+1

      n1=nx/2
      n=n1*ny*nz
      call FFT(a,b,ny*nz,n1,1,-1)
      call REALT(a,b,ny*nz,n1,1,-1)
      call FFT(a(n+1),b(n+1),nz,ny,1,-1)
      call FFT(a(n+1),b(n+1),1,nz,ny,-1)
      call FFT(a,b,nz,ny,n1,-1)
      call FFT(a,b,1,nz,n1*ny,-1)

      i=1
      do 31 iz=1,nz
      if(iz.le.nz/2+1)then
        fz=float(iz-1)/(float(nz)*cmppix(3))
      else
        fz=float(nz-iz+1)/(float(nz)*cmppix(3))
      endif
      do 31 iy=1,ny
      if(iy.le.ny/2+1)then
        fy=float(iy-1)/(float(ny)*cmppix(2))
      else
        fy=float(ny-iy+1)/(float(ny)*cmppix(2))
      endif
      do 31 ix=1,n1
        fx=float(ix-1)/(float(nx)*cmppix(1))
      f2=fx**2+fy**2+fz**2
      factor=exp(-alog(2.)*f2/fhalf**2)
      a(i)=factor*a(i)
      b(i)=factor*b(i)
   31 i=i+1
      fx=0.5/cmppix(1)
      do 32 iz=1,nz
      if(iz.le.nz/2+1)then
        fz=float(iz-1)/(float(nz)*cmppix(3))
      else
        fz=float(nz-iz+1)/(float(nz)*cmppix(3))
      endif
      do 32 iy=1,ny
      if(iy.le.ny/2+1)then
        fy=float(iy-1)/(float(ny)*cmppix(2))
      else
        fy=float(ny-iy+1)/(float(ny)*cmppix(2))
      endif
      f2=fx**2+fy**2+fz**2
      factor=exp(-alog(2.)*f2/fhalf**2)
      a(i)=factor*a(i)
      b(i)=factor*b(i)
   32 i=i+1

      call FFT(a,b,1,nz,n1*ny,+1)
      call FFT(a,b,nz,ny,n1,+1)
      call FFT(a(n+1),b(n+1),1,nz,ny,+1)
      call FFT(a(n+1),b(n+1),nz,ny,1,+1)
      call REALT(a,b,ny*nz,n1,1,+1)
      call FFT(a,b,ny*nz,n1,1,+1)

      i=1
      do 29 iz=1,nz
      do 29 iy=1,ny
      do 29 ix=1,nx,2
      image(ix,iy,iz)=a(i)
      image(ix+1,iy,iz)=b(i)
   29 i=i+1

      call free(pa)
      call free(pb)
      return
      end


C  (C) Copr. 1986-92 Numerical Recipes Software ]2w.1,r1..

      FUNCTION pvdpythag(a,b)
      implicit none
      DOUBLE PRECISION a,b,pvdpythag
      DOUBLE PRECISION absa,absb
      absa=abs(a)
      absb=abs(b)
      if(absa.gt.absb)then
        pvdpythag=absa*sqrt(1.0d0+(absb/absa)**2)
      else
        if(absb.eq.0.0d0)then
          pvdpythag=0.0d0
        else
          pvdpythag=absb*sqrt(1.0d0+(absa/absb)**2)
        endif
      endif
      return
      END


MODULE global_minimum

! This is translated from the code of:
! Dr. Tibor Csendes
! Dept. of Applied Informatics, Jozsef Attila University
! H-6701 Szeged, Pf. 652, Hungary

! Phone: +36 62 544 305

! Fax: +36 62 420 292

! E-mail: csendes@inf.u-szeged.hu

! URL: http://www.inf.u-szeged.hu/~csendes/

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

CONTAINS

!   ROUTINE NAME - GLOBAL

! Code converted using TO_F90 by Alan Miller
! Date: 1999-12-27  Time: 13:16:39

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

!   LATEST REVISION - OKTOBER 23, 1986
!   Latest revision of Fortran 90 version - 30 January 2000

!   PURPOSE  - GLOBAL MINIMUM OF FUNCTION OF N VARIABLES
!              USING A LOCAL SEARCH METHOD

!   USAGE  - CALL GLOBAL (AMIN, AMAX, NPARM, M, N100, NG0, IPR,
!                         NSIG, X0, NC, F0)

!   ARGUMENTS
!  AMIN - VECTOR OF LENGTH NPARM CONTAINING THE LOWER BOUNDS OF THE
!         PARAMETERS, SO X(I) IS SEARCHED IN THE INTERVAL (AMIN(I), AMAX(I)).
!         (INPUT)
!  AMAX - VECTOR OF LENGTH NPARM CONTAINING THE UPPER BOUNDS OF THE
!         PARAMETERS. (INPUT)
! NPARM - NUMBER OF PARAMETERS, 1 <= NPARM <= 20. (INPUT)
!     M - NUMBER OF RESIDUAL FUNCTIONS, WHEN THE OBJECTIVE FUNCTION IS OF THE
!         FORM F1**2 + F2**2 +...+ FM**2, 1 <=M <= 100. (INPUT)
!         N.B. M is NOT used for this purpose!
!              It is passed to the user's routine FUNCT as a parameter.
!  N100 - NUMBER OF SAMPLE POINTS TO BE DRAWN UNIFORMLY IN ONE CYCLE,
!         20 <= N100 <= 10000. THE SUGGESTED VALUE IS 100*NPARM. (INPUT)
!   NG0 - NUMBER OF BEST POINTS SELECTED FROM THE ACTUAL SAMPLE, 1 <= NG0 <= 20.
!         THE SUGGESTED VALUE IS TWICE THE EXPECTED NUMBER OF LOCAL MINIMA.
!         (INPUT)
!   IPR - FORTRAN DATA SET REFERENCE NUMBER WHERE THE PRINTED OUTPUT BE SENT.
!         (INPUT)
!  NSIG - CONVERGENCE CRITERION, THE ACCURACY REQUIRED IN THE PARAMETER
!         ESTIMATES.  THIS CONVERGENCE CRITERION IS SATISFIED IF ON TWO
!         SUCCESSIVE ITERATIONS THE PARAMETER ESTIMATES AGREE, COMPONENT BY
!         COMPONENT, TO NSIG DIGITS.  THE SUGGESTED VALUE IS 6. (INPUT)
!    X0 - OUTPUT NPARM BY 20 MATRIX CONTAINING NC (UP TO 20) LOCAL MINIMIZERS
!         FOUND.
!    NC - NUMBER OF DIFFERENT LOCAL MINIMIZERS FOUND. (OUTPUT)
!    F0 - OUTPUT VECTOR OF NC (UP TO 20) OBJECTIVE FUNCTION VALUES, F0(I)
!         BELONGS TO THE PARAMETERS X0(1,I), X0(2,I),..., X0(NPARM,I).

!   REQUIRED ROUTINES - URDMN, FUN, LOCAL

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

SUBROUTINE global(amin, amax, nparm, m, n100, ng0, ipr, nsig, x0, nc, f0)

REAL (dp), INTENT(IN)    :: amin(:)
REAL (dp), INTENT(IN)    :: amax(:)
INTEGER, INTENT(IN)      :: nparm
INTEGER, INTENT(IN)      :: m
INTEGER, INTENT(IN OUT)  :: n100
INTEGER, INTENT(IN OUT)  :: ng0
INTEGER, INTENT(IN)      :: ipr
INTEGER, INTENT(IN)      :: nsig
REAL (dp), INTENT(OUT)   :: x0(:,:)
INTEGER, INTENT(OUT)     :: nc
REAL (dp), INTENT(OUT)   :: f0(:)

REAL (dp) :: x(nparm,100), x1(nparm,20), xcl(nparm,100), r(nparm), w(nparm)
INTEGER   :: ic(100), ic1(20)
INTEGER   :: i, i1, icc, icj, ig, ii, iii, im, in1, inum, inum1, inum2, it, &
             iv, j, jj, l1, maxfn, n, n0, n1, ncp, nfe, nfe1, ng, ng10, nm, &
             nn100, ns
REAL (dp) :: f(100), f1(20), fcl(100), y(nparm), mmin(nparm), mmax(nparm)
REAL (dp) :: a, alfa, b, b1, bb, fc, ff, fm, relcon
REAL (dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp, two = 2.0_dp, ten = 10._dp

DO  i=1,nparm
  mmin(i) = amin(i)
  mmax(i) = amax(i)
  IF (mmin(i) == mmax(i)) GO TO 460
END DO
b1 = one/nparm

IF (ng0 < 1) ng0 = 1
IF (ng0 > 20) ng0 = 20
IF (n100 < 20) n100 = 20
IF (n100 > 10000) n100 = 10000
IF (n100 >= 100) GO TO 10

nn100 = n100
n = 1
GO TO 15

10 nn100 = 100
n = n100/100
n100 = n*100

15 ng10 = 100
DO  i=1,ng10
  f(i) = HUGE(one)
  ic(i) = 0
END DO
DO  i=1,nparm
  mmax(i) = (mmax(i) - mmin(i))/two
  mmin(i) = mmin(i) + mmax(i)
END DO
alfa = 0.01_dp
nfe = 0
ng = 0
ns = 0
nc = 0
ncp = 1
n0 = 0
n1 = 0
im = 1
ig = 0
fm = HUGE(one)
maxfn = 500*nparm
relcon = ten**(-nsig)

!         SAMPLING
20 n0 = n0 + n100
nm = n0 - 1
ng = ng + ng0
ns = ns + 1
IF (ns*ng0 > 100) GO TO 465
b = (one - alfa**(one/REAL(nm)))**b1
bb = 0.1*b
DO  i1=1,n
  DO  j=1,nn100
    CALL RANDOM_NUMBER( r )
    DO  i=1,nparm
      y(i) = two*r(i) - one
    END DO
    CALL fun(y, fc, nparm, m, mmin, mmax)
    IF (fc >= fm) CYCLE
    f(im) = fc
    DO  i=1,nparm
      x(i,im) = y(i)
    END DO
    IF (im <= ng .AND. ic(im) > 0) ig = ig - 1
    ic(im) = 0
    im = 1
    fm = f(1)
    DO  i=2,ng10
      IF (f(i) < fm) CYCLE
      im = i
      fm = f(i)
    END DO
  END DO
END DO

nfe = nfe + n100
WRITE(ipr,901) n100
WRITE(*,901) n100
901 FORMAT(/' ', i5, ' FUNCTION EVALUATIONS USED FOR SAMPLING')

!        SORTING
inum = ng10 - 1
DO  i=1,inum
  im = i
  fm = f(i)
  inum1 = i + 1
  DO  j=inum1,ng10
    IF (f(j) >= fm) CYCLE
    im = j
    fm = f(j)
  END DO
  IF (im <= i) CYCLE
  a = fm
  DO  j=1,nparm
    y(j) = x(j,im)
  END DO
  IF (i > ng .OR. im <= ng) GO TO 55
  IF (ic(ng) == 0 .AND. ic(im) > 0) ig = ig+1
  IF (ic(ng) > 0 .AND. ic(im) == 0) ig = ig-1
  55 icc = ic(im)
  inum1 = im-i
  DO  j=1,inum1
    inum2 = im-j
    f(inum2+1) = f(inum2)
    ic(inum2+1) = ic(inum2)
    DO  jj=1,nparm
      x(jj,inum2+1) = x(jj,inum2)
    END DO
  END DO
  f(i) = a
  DO  j=1,nparm
    x(j,i) = y(j)
  END DO
  ic(i) = icc
END DO
IF (nc <= 0) GO TO 200

!     CLUSTERING TO X*
DO  iii=1,nc
  i = 1
  in1 = i
  fcl(i) = f0(iii)
  DO  j=1,nparm
    xcl(j,i) = x0(j,iii)
  END DO
  DO  j=1,ng
    IF (ic(j) /= iii) CYCLE
    in1 = in1+1
    DO  ii=1,nparm
      xcl(ii,in1) = x(ii,j)
    END DO
  END DO
  95 DO  j=1,ng
    IF (ic(j) /= 0) CYCLE
    IF (fcl(i) >= f(j)) CYCLE
    DO  l1=1,nparm
      w(l1) = ABS(xcl(l1,i)-x(l1,j))
    END DO
    a = zero
    DO  l1=1,nparm
      IF (w(l1) > a) a = w(l1)
    END DO
    IF (a >= b) CYCLE
    WRITE(ipr,902) iii
    WRITE(*,902) iii
    902 FORMAT(' SAMPLE POINT ADDED TO THE CLUSTER NO. ', i2)
    DO  ii=1,nparm
      w(ii) = x(ii,j)*mmax(ii) + mmin(ii)
    END DO
    WRITE(ipr,903) f(j), w(1:nparm)
    WRITE (*,903) f(j), w(1:nparm)
    903 FORMAT(' ', g14.8/ ('    ', 5(g14.8, ' ')))
    ig = ig+1
    IF (ig >= ng) GO TO 395
    in1 = in1+1
    fcl(in1) = f(j)
    DO  ii=1,nparm
      xcl(ii,in1) = x(ii,j)
    END DO
    ic(j) = iii
  END DO
  i = i+1
  IF (i <= in1) GO TO 95
END DO
IF (n1 <= 0) GO TO 200

!     CLUSTERING TO X1
DO  iii=1,n1
  i = 1
  in1 = i
  fcl(i) = f1(iii)
  DO  j=1,nparm
    xcl(j,i) = x1(j,iii)
  END DO
  155 DO  j=1,ng
    IF (ic(j) /= 0) CYCLE
    IF (fcl(i) >= f(j)) CYCLE
    DO  l1=1,nparm
      w(l1) = ABS(xcl(l1,i)-x(l1,j))
    END DO
    a = zero
    DO  l1=1,nparm
      IF (w(l1) > a) a=w(l1)
    END DO
    IF (a >= b) CYCLE
    WRITE(ipr,902) ic1(iii)
    WRITE(*,902) ic1(iii)
    DO  ii=1,nparm
      w(ii) = x(ii,j)*mmax(ii) + mmin(ii)
    END DO
    WRITE(ipr,903) f(j), w(1:nparm)
    WRITE(*,903) f(j), w(1:nparm)
    ig = ig+1
    IF (ig >= ng) GO TO 395
    in1 = in1+1
    fcl(in1) = f(j)
    DO  ii=1,nparm
      xcl(ii,in1) = x(ii,j)
    END DO
    ic(j) = ic1(iii)
  END DO
  i = i+1
  IF (i <= in1) GO TO 155
END DO

!     LOCAL SEARCH
200 it = 0
DO  i1=1,ng
  IF (ic(i1) /= 0) CYCLE
  DO  i=1,nparm
    y(i) = x(i,i1)
  END DO
  ff = f(i1)
  CALL local(m, nparm, relcon, maxfn, y, ff, nfe1, mmin, mmax)
  IF (nc <= 0) GO TO 290
  DO  iv=1,nc
    DO  l1=1,nparm
      w(l1) = ABS(x0(l1,iv) - y(l1))
    END DO
    a = zero
    DO  l1=1,nparm
      IF (w(l1) > a) a = w(l1)
    END DO
    IF (a < bb) GO TO 255
  END DO
  GO TO 290

!       NEW SEED-POINT
  255 n1 = n1 + 1
  WRITE(ipr,905) iv, nfe1
  WRITE(*,905) iv,nfe1
  905 FORMAT(' NEW SEED POINT ADDED TO THE CLUSTER NO. ', i2, ', NFEV=', i5)
  DO  ii=1,nparm
    w(ii) = x(ii,i1)*mmax(ii) + mmin(ii)
  END DO
  WRITE(ipr,903) ff, w(1:nparm)
  WRITE(*,903) ff, w(1:nparm)
  IF (ff >= f0(iv)) GO TO 280
  WRITE(ipr,906) iv, f0(iv), ff
  WRITE(*,906) iv,f0(iv),ff
  906 FORMAT(' *** IMPROVEMENT ON THE LOCAL MINIMUM NO. ',  &
             i2, ':', g14.8, ' FOR ', g14.8)
  w(1:nparm) = y(1:nparm)*mmax(1:nparm) + mmin(1:nparm)
  WRITE(ipr,903) ff, w(1:nparm)
  WRITE(*,903) ff, w(1:nparm)
  f0(iv) = ff
  DO  ii=1,nparm
    x0(ii,iv) = y(ii)
  END DO
  280 IF (n1 > 20) GO TO 470
  DO  ii=1,nparm
    x1(ii,n1) = x(ii,i1)
    xcl(ii,1) = x(ii,i1)
  END DO
  f1(n1) = f(i1)
  fcl(1) = f(i1)
  ic1(n1) = iv
  icj = iv
  GO TO 305

!     NEW LOCAL MINIMUM
  290 nc = nc+1
  ncp = ncp+1
  WRITE(ipr,907) nc, ff, nfe1
  WRITE(*,907) nc, ff, nfe1
  907 FORMAT(' *** THE LOCAL MINIMUM NO. ', i2, ': ', g14.8, ', NFEV=', i5)
  DO  ii=1,nparm
    w(ii) = y(ii)*mmax(ii) + mmin(ii)
  END DO
  WRITE(ipr,903) ff, w(1:nparm)
  WRITE(*,903) ff, w(1:nparm)
  DO  ii=1,nparm
    x0(ii,nc) = y(ii)
    xcl(ii,1) = y(ii)
  END DO
  fcl(1) = ff
  f0(nc) = ff
  IF (nc >= 20) GO TO 475
  it = 1
  icj = nc

!    CLUSTERING TO THE NEW POINT
  305 nfe = nfe + nfe1
  ic(i1) = icj
  ig = ig + 1
  IF (ig >= ng) EXIT
  i = 1
  in1 = i
  310 DO  j=1,ng
    IF (ic(j) /= 0) CYCLE
    IF (fcl(i) >= f(j)) CYCLE
    DO  l1=1,nparm
      w(l1) = ABS(xcl(l1,i) - x(l1,j))
    END DO
    a = zero
    DO  l1=1,nparm
      IF (w(l1) > a) a = w(l1)
    END DO
    IF (a >= b) CYCLE
    in1 = in1 + 1
    DO  ii=1,nparm
      xcl(ii,in1) = x(ii,j)
    END DO
    fcl(in1) = f(j)
    ic(j) = icj
    WRITE(ipr,902) icj
    WRITE(*,902) icj
    DO  ii=1,nparm
      w(ii) = x(ii,j)*mmax(ii) + mmin(ii)
    END DO
    WRITE(ipr,903) f(j), w(1:nparm)
    WRITE(*,903) f(j), w(1:nparm)
    ig = ig+1
    IF (ig >= ng) EXIT
  END DO
  i = i+1
  IF (i < in1) GO TO 310
END DO
IF (it /= 0) GO TO 20

!      PRINT RESULTS
395 WRITE(ipr,908)
WRITE(*,908)
908 FORMAT(///' LOCAL MINIMA FOUND:'//)
IF (nc <= 1) GO TO 430
inum = nc - 1
DO  i=1,inum
  im = i
  fm = f0(i)
  inum1 = i + 1
  DO  j=inum1,nc
    IF (f0(j) >= fm) CYCLE
    im = j
    fm = f0(j)
  END DO
  IF (im <= i) CYCLE
  a = fm
  y(1:nparm) = x0(1:nparm,im)
  inum1 = im-i
  DO  j=1,inum1
    inum2 = im - j
    f0(inum2+1) = f0(inum2)
    DO  jj=1,nparm
      x0(jj,inum2+1) = x0(jj,inum2)
    END DO
  END DO
  f0(i) = a
  x0(1:nparm,i) = y(1:nparm)
END DO
430 IF (nc <= 0) GO TO 445

DO  i=1,nc
  x0(1:nparm,i) = x0(1:nparm,i)*mmax(1:nparm) + mmin(1:nparm)
  WRITE(ipr,903) f0(i), x0(1:nparm,i)
  WRITE(*,903) f0(i), x0(1:nparm,i)
END DO

445 WRITE(ipr,911) nfe
WRITE(*,911) nfe
911 FORMAT(//' NORMAL TERMINATION AFTER ', i5, ' FUNCTION EVALUATIONS'//)
RETURN

460 WRITE(ipr,914)
WRITE(*,914)
914 FORMAT(' ***   DATA ERROR')
STOP

465 WRITE(ipr,915)
WRITE(*,915)
915 FORMAT(' ***   TOO MANY SAMPLES')
GO TO 395

470 WRITE(ipr,916)
WRITE(*,916)
916 FORMAT(' ***   TOO MANY NEW SEED POINTS')
GO TO 395

475 WRITE(ipr,917)
WRITE(*,917)
917 FORMAT(' ***   TOO MANY CLUSTERS')
GO TO 395
END SUBROUTINE global

SUBROUTINE fun(r, f, nparm, m, mmin, mmax)

REAL (dp), INTENT(IN)   :: r(:)
REAL (dp), INTENT(OUT)  :: f
INTEGER, INTENT(IN)     :: nparm
INTEGER, INTENT(IN)     :: m
REAL (dp), INTENT(IN)   :: mmin(:)
REAL (dp), INTENT(IN)   :: mmax(:)

INTERFACE
  SUBROUTINE funct(x, f, nparm, m)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)   :: x(:)
    REAL (dp), INTENT(OUT)  :: f
    INTEGER, INTENT(IN)     :: nparm, m
  END SUBROUTINE funct
END INTERFACE

REAL (dp) :: x(nparm)

! N.B. mmin = mid-point between lower & upper limits
!      mmax = (upper - lower limits) / 2

x(1:nparm) = mmax(1:nparm)*r(1:nparm) + mmin(1:nparm)
CALL funct(x, f, nparm, m)

RETURN
END SUBROUTINE fun

!   ROUTINE NAME - LOCAL

! Code converted using TO_F90 by Alan Miller
! Date: 1999-12-27  Time: 13:16:43

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

!   LATEST REVISION - JULY 31, 1986

!   PURPOSE  - MINIMUM OF A FUNCTION OF N VARIABLES USING
!       A QUASI-NEWTON METHOD

!   USAGE  - CALL LOCAL (M, N, EPS, MAXFN, X, F, NFEV, mmin, mmax)

!   ARGUMENTS  M - THE NUMBER OF RESIDUAL FUNCTIONS (INPUT)
!       NOT USED IN THIS ROUTINE.
!   N - THE NUMBER OF PARAMETERS (I.E., THE LENGTH OF X) (INPUT)
!   EPS - CONVERGENCE CRITERION. (INPUT).  THE ACCURACY REQUIRED IN THE
!       PARAMETER ESTIMATES.
!       THIS CONVERGENCE CONDITION IS SATISFIED IF ON TWO SUCCESSIVE
!       ITERATIONS, THE PARAMETER ESTIMATES (I.E.,X(I), I=1,...,N) DIFFERS,
!       COMPONENT BY COMPONENT, BY AT MOST EPS.
!   MAXFN - MAXIMUM NUMBER OF FUNCTION EVALUATIONS (I.E.,
!       CALLS TO SUBROUTINE FUN) ALLOWED. (INPUT)
!   X - VECTOR OF LENGTH N CONTAINING PARAMETER VALUES.
!     ON INPUT, X MUST CONTAIN THE INITIAL PARAMETER ESTIMATES.
!     ON OUTPUT, X CONTAINS THE FINAL PARAMETER
!       ESTIMATES AS DETERMINED BY LOCAL.
!   F - A SCALAR CONTAINING THE VALUE OF THE FUNCTION
!       AT THE FINAL PARAMETER ESTIMATES. (OUTPUT)
!   NFEV - THE NUMBER OF FUNCTION EVALUATIONS (OUTPUT)
!   W - A VECTOR OF LENGTH 3*N USED AS WORKING SPACE.
!   mmin    - A VECTOR OF LENGTH N CONTAINING THE LOWER
!              BOUNDS OF THE PARAMETERS, SO X(I) IS
!              SEARCHED IN THE INTERVAL (mmin(I),mmax(I)).
!              (INPUT)
!   mmax    - A VECTOR OF LENGTH N CONTAINING THE UPPER
!              BOUNDS OF THE PARAMETERS. (INPUT)

!   REQUIRED ROUTINES - UPDATE, FUN

!   FUN   - A USER SUPPLIED SUBROUTINE WHICH CALCULATES THE FUNCTION F FOR
!           GIVEN PARAMETER VALUES X(1),X(2),...,X(N).
!           THE CALLING SEQUENCE HAS THE FOLLOWING FORM
!              CALL FUN(X, F, N, M, mmin, mmax)
!           WHERE X IS A VEKTOR OF LENGTH N.
!           FUN MUST APPEAR IN AN EXTERNAL STATEMENT IN THE CALLING PROGRAM.
!           FUN MUST NOT ALTER THE VALUES OF X(I), I=1,...,N OR N.

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

SUBROUTINE local (m, n, eps, maxfn, x, f, nfev, mmin, mmax)

! N.B. Argument W has been removed.

!       SPECIFICATIONS FOR ARGUMENTS

INTEGER, INTENT(IN)        :: m
INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN)      :: eps
INTEGER, INTENT(IN)        :: maxfn
REAL (dp), INTENT(IN OUT)  :: x(:)
REAL (dp), INTENT(OUT)     :: f
INTEGER, INTENT(OUT)       :: nfev
REAL (dp), INTENT(IN)      :: mmin(:)
REAL (dp), INTENT(IN)      :: mmax(:)

!       SPECIFICATIONS FOR LOCAL VARIABLES
REAL (dp) :: w(3*n)
INTEGER   :: ig, igg, im1, is, idiff, ir, ij, i, iopt, j, nm1, jj, jp1, l, &
             kj, k, link, itn, ii, jnt, np1, jb, nj, ier
REAL (dp) :: hh, hjj, v, df, relx, gs0, diff, aeps, alpha, ff, tot, f1, f2, &
             z, gys, dgs, sig, zz, hhh, ghh, g(n), h(n*n)
REAL (dp), PARAMETER :: reps = 1.1921E-07_dp, ax = 0.1_dp, zero = 0.0_dp,  &
                        one = 1.0_dp, half = 0.5_dp, seven = 7.0_dp,  &
                        five = 5.0_dp, twelve = 12.0_dp, p1 = 0.1_dp

!       INITIALIZATION
!       FIRST EXECUTABLE STATEMENT
iopt = 0

!   IOPT - OPTIONS SELECTOR. (INPUT)
!     IOPT = 0 CAUSES LOCAL TO INITIALIZE THE
!       HESSIAN MATRIX H TO THE IDENTITY MATRIX.
!     IOPT = 1 INDICATES THAT H HAS BEEN INITIALIZED
!       BY THE USER TO A POSITIVE DEFINITE MATRIX.
!     IOPT = 2 CAUSES LOCAL TO COMPUTE THE DIAGONAL
!       VALUES OF THE HESSIAN MATRIX AND SET H TO
!       A DIAGONAL MATRIX CONTAINING THESE VALUES.
!     IOPT = 3 CAUSES LOCAL TO COMPUTE AN ESTIMATE
!       OF THE HESSIAN IN H.
ier = 0
hh = SQRT(reps)
ig = n
igg = n+n
is = igg
idiff = 1
ir = n
w(1) = -one
w(2) = zero
w(3) = zero

!       EVALUATE FUNCTION AT STARTING POINT
g(1:n) = x(1:n)
CALL fun (g, f, n, m, mmin, mmax)
nfev = 1
IF (iopt == 1) GO TO 45

!       SET OFF-DIAGONAL ELEMENTS OF H TO 0.0
IF (n == 1) GO TO 25
ij = 2
DO  i=2,n
  DO  j=2,i
    h(ij) = zero
    ij = ij + 1
  END DO
  ij = ij + 1
END DO
IF (iopt /= 0) GO TO 25

!       SET DIAGONAL ELEMENTS OF H TO ONE
ij = 0
DO  i=1,n
  ij = ij+i
  h(ij) = one
END DO
GO TO 80

!       GET DIAGONAL ELEMENTS OF HESSIAN
25 im1 = 1
nm1 = 1
np1 = n+1
DO  i=2,np1
  hhh = hh*MAX(ABS(x(im1)), ax)
  g(im1) = x(im1) + hhh
  CALL fun (g, f2, n, m, mmin, mmax)
  g(im1) = g(im1) + hhh
  CALL fun (g, ff, n, m, mmin, mmax)
  h(nm1) = (ff-f2+f-f2)/(hhh*hhh)
  g(im1) = x(im1)
  im1 = i
  nm1 = i+nm1
END DO
nfev = nfev+n+n
IF (iopt /= 3 .OR. n == 1) GO TO 45

!       GET THE REST OF THE HESSIAN
jj = 1
ii = 2
DO  i=2,n
  ghh = hh*MAX(ABS(x(i)), ax)
  g(i) = x(i)+ghh
  CALL fun (g, f2, n, m, mmin, mmax)
  DO  j=1,jj
    hhh = hh*MAX(ABS(x(j)), ax)
    g(j) = x(j) + hhh
    CALL fun (g, ff, n, m, mmin, mmax)
    g(i) = x(i)
    CALL fun (g, f1, n, m, mmin, mmax)
!     H(II) = (FF-F1-F2+F)*SQREPS
    h(ii) = (ff-f1-f2+f)/(hhh*ghh)
    ii = ii+1
    g(j) = x(j)
  END DO
  jj = jj+1
  ii = ii+1
END DO
nfev = nfev + ((n*n-n)/2)

!       FACTOR H TO L*D*L-TRANSPOSE
45 ir = n
IF (n > 1) GO TO 50
IF (h(1) > zero) GO TO 80
h(1) = zero
ir = 0
GO TO 75
50 nm1 = n-1
jj = 0
DO  j=1,n
  jp1 = j+1
  jj = jj+j
  hjj = h(jj)
  IF (hjj > zero) GO TO 55
  h(jj) = zero
  ir = ir-1
  CYCLE
  55 IF (j == n) CYCLE
  ij = jj
  l = 0
  DO  i=jp1,n
    l = l+1
    ij = ij+i-1
    v = h(ij)/hjj
    kj = ij
    DO  k=i,n
      h(kj+l) = h(kj+l) - h(kj)*v
      kj = kj + k
    END DO
    h(ij) = v
  END DO
END DO
75 IF (ir /= n) THEN
  ier = 129
  GO TO 9000
END IF
80 itn = 0
df = -one

!       EVALUATE GRADIENT W(IG+I),I=1,...,N
85 link = 1
GO TO 260

!       BEGIN ITERATION LOOP
90 IF (nfev >= maxfn) GO TO 225
itn = itn+1
DO  i=1,n
  w(i) = -w(ig+i)
END DO

!       DETERMINE SEARCH DIRECTION W
!         BY SOLVING H*W = -G WHERE
!         H = L*D*L-TRANSPOSE
IF (ir < n) GO TO 125
!       N .EQ. 1
g(1) = w(1)
IF (n > 1) GO TO 100
w(1) = w(1)/h(1)
GO TO 125
!       N > 1
100 ii = 1

!       SOLVE L*W = -G
DO  i=2,n
  ij = ii
  ii = ii+i
  v = w(i)
  im1 = i-1
  DO  j=1,im1
    ij = ij+1
    v = v - h(ij)*w(j)
  END DO
  g(i) = v
  w(i) = v
END DO

!       SOLVE (D*LT)*Z = W WHERE
!                                    LT = L-TRANSPOSE
w(n) = w(n)/h(ii)
jj = ii
nm1 = n-1
DO  nj=1,nm1
!       J = N-1,N-2,...,1
  j = n-nj
  jp1 = j+1
  jj = jj-jp1
  v = w(j)/h(jj)
  ij = jj
  DO  i=jp1,n
    ij = ij+i-1
    v = v - h(ij)*w(i)
  END DO
  w(j) = v
END DO

!       DETERMINE STEP LENGTH ALPHA
125 relx = zero
gs0 = zero
DO  i=1,n
  w(is+i) = w(i)
  diff = ABS(w(i)) / MAX(ABS(x(i)),ax)
  relx = MAX(relx, diff)
  gs0 = gs0 + w(ig+i)*w(i)
END DO
IF (relx == zero) GO TO 230
aeps = eps/relx
ier = 130
IF (gs0 >= zero) GO TO 230
IF (df == zero) GO TO 230
ier = 0
alpha = (-df-df)/gs0
IF (alpha <= zero) alpha = one
alpha = MIN(alpha,one)
IF (idiff == 2) alpha = MAX(p1,alpha)
ff = f
tot = zero
jnt = 0

!       SEARCH ALONG X + ALPHA*W
135 IF (nfev >= maxfn) GO TO 225
DO  i=1,n
  w(i) = x(i) + alpha*w(is+i)
END DO
CALL fun (w, f1, n, m, mmin, mmax)
nfev = nfev+1
IF (f1 >= f) GO TO 165
f2 = f
tot = tot + alpha
145 ier = 0
f = f1
x(1:n) = w(1:n)
IF (jnt-1 < 0) THEN
  GO TO   155
ELSE IF (jnt-1 == 0) THEN
  GO TO 185
ELSE
  GO TO 190
END IF

155 IF (nfev >= maxfn) GO TO 225
DO  i=1,n
  w(i) = x(i) + alpha*w(is+i)
END DO
CALL fun (w, f1, n, m, mmin, mmax)
nfev = nfev+1
IF (f1 >= f) GO TO 190
IF (f1+f2 >= f+f .AND. seven*f1+five*f2 > twelve*f) jnt = 2
tot = tot + alpha
alpha = alpha + alpha
GO TO 145

165 IF (f == ff .AND. idiff == 2 .AND. relx > eps) ier = 130
IF (alpha < aeps) GO TO 230
IF (nfev >= maxfn) GO TO 225
alpha = half*alpha
DO  i=1,n
  w(i) = x(i) + alpha*w(is+i)
END DO
CALL fun (w, f2, n, m, mmin, mmax)
nfev = nfev + 1
IF (f2 >= f) GO TO 180
tot = tot + alpha
ier = 0
f = f2
x(1:n) = w(1:n)
GO TO 185

180 z = p1
IF (f1+f > f2+f2) z = one + half*(f-f1)/(f+f1-f2-f2)
z = MAX(p1,z)
alpha = z*alpha
jnt = 1
GO TO 135

185 IF (tot < aeps) GO TO 230
190 alpha = tot

!       SAVE OLD GRADIENT
DO  i=1,n
  w(i) = w(ig+i)
END DO

!       EVALUATE GRADIENT W(IG+I), I=1,...,N
link = 2
GO TO 260
200 IF (nfev >= maxfn) GO TO 225
gys = zero
DO  i=1,n
  gys = gys + w(ig+i)*w(is+i)
  w(igg+i) = w(i)
END DO
df = ff-f
dgs = gys-gs0
IF (dgs <= zero) GO TO 90
IF (dgs + alpha*gs0 > zero) GO TO 215

!       UPDATE HESSIAN H USING
!         COMPLEMENTARY DFP FORMULA
sig = one/gs0
ir = -ir
CALL update (h, n, w, sig, g, ir, 0, zero)
DO  i=1,n
  g(i) = w(ig+i) - w(igg+i)
END DO
sig = one/(alpha*dgs)
ir = -ir
CALL update (h, n, g, sig, w, ir, 0, zero)
GO TO 90

!       UPDATE HESSIAN USING DFP FORMULA
215 zz = alpha/(dgs - alpha*gs0)
sig = -zz
CALL update (h, n, w, sig, g, ir, 0, reps)
z = dgs*zz - one
DO  i=1,n
  g(i) = w(ig+i) + z*w(igg+i)
END DO
sig = one/(zz*dgs*dgs)
CALL update (h, n, g, sig, w, ir, 0, zero)
GO TO 90

!       MAXFN FUNCTION EVALUATIONS
225 GO TO 235
230 IF (idiff == 2) GO TO 235

!       CHANGE TO CENTRAL DIFFERENCES
idiff = 2
GO TO 85
235 IF (relx > eps .AND. ier == 0) GO TO 85

!       COMPUTE H = L*D*L-TRANSPOSE AND OUTPUT
IF (n == 1) GO TO 9000
np1 = n+1
nm1 = n-1
jj = (n*(np1))/2
DO  jb=1,nm1
  jp1 = np1-jb
  jj = jj-jp1
  hjj = h(jj)
  ij = jj
  l = 0
  DO  i=jp1,n
    l = l+1
    ij = ij+i-1
    v = h(ij)*hjj
    kj = ij
    DO  k=i,n
      h(kj+l) = h(kj+l) + h(kj)*v
      kj = kj + k
    END DO
    h(ij) = v
  END DO
  hjj = h(jj)
END DO
GO TO 9000

!        EVALUATE GRADIENT
260 IF (idiff == 2) GO TO 270

!       FORWARD DIFFERENCES
!         GRADIENT = W(IG+I), I=1,...,N
DO  i=1,n
  z = hh*MAX(ABS(x(i)),ax)
  zz = x(i)
  x(i) = zz + z
  CALL fun (x, f1, n, m, mmin, mmax)
  w(ig+i) = (f1-f)/z
  x(i) = zz
END DO
nfev = nfev+n
SELECT CASE ( link )
  CASE (    1)
    GO TO 90
  CASE (    2)
    GO TO 200
END SELECT

!       CENTRAL DIFFERENCES
!         GRADIENT = W(IG+I), I=1,...,N
270 DO  i=1,n
  z = hh*MAX(ABS(x(i)), ax)
  zz = x(i)
  x(i) = zz + z
  CALL fun (x, f1, n, m, mmin, mmax)
  x(i) = zz-z
  CALL fun (x, f2, n, m, mmin, mmax)
  w(ig+i) = (f1-f2)/(z+z)
  x(i) = zz
END DO
nfev = nfev+n+n
SELECT CASE ( link )
  CASE (    1)
    GO TO 90
  CASE (    2)
    GO TO 200
END SELECT

!       RETURN
9000 RETURN
END SUBROUTINE local

!   ROUTINE NAME - UPDATE

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

!   LATEST REVISION     - JULY 31, 1986
!     (CHANGES IN COMMENTS)

!   PURPOSE  - NUCLEUS CALLED ONLY BY ROUTINE LOCAL

!   REQD. ROUTINES - NONE REQUIRED

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

SUBROUTINE update (a, n, z, sig, w, ir, mk, eps)
!       SPECIFICATIONS FOR ARGUMENTS

REAL (dp), INTENT(OUT)     :: a(:)
INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: z(:)
REAL (dp), INTENT(IN)      :: sig
REAL (dp), INTENT(IN OUT)  :: w(:)
INTEGER, INTENT(OUT)       :: ir
INTEGER, INTENT(IN)        :: mk
REAL (dp), INTENT(IN)      :: eps

!       SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER   :: j, jj, ij, jp1, i, ii, mm
REAL (dp) :: ti, v, tim, al, r, b, gm, y
REAL (dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp, four = 4.0_dp

!       UPDATE FACTORS GIVEN IN A
!         SIG*Z*Z-TRANSPOSE IS ADDED
!       FIRST EXECUTABLE STATEMENT
IF (n > 1) GO TO 5

!       N .EQ. 1
a(1) = a(1) + sig*z(1)*z(1)
ir = 1
IF (a(1) > zero) GO TO 9005
a(1) = zero
ir = 0
GO TO 9005

!       N > 1
5 IF (sig > zero) GO TO 65
IF (sig == zero .OR. ir == 0) GO TO 9005
ti = one/sig
jj = 0
IF (mk == 0) GO TO 15

!       L*W = Z ON INPUT
DO  j=1,n
  jj = jj+j
  IF (a(jj) /= zero) ti = ti + (w(j)*w(j))/a(jj)
END DO
GO TO 40

!       SOLVE L*W = Z
15 w(1:n) = z(1:n)
DO  j=1,n
  jj = jj+j
  v = w(j)
  IF (a(jj) > zero) GO TO 25
  w(j) = zero
  CYCLE
  25 ti = ti+(v*v)/a(jj)
  IF (j == n) CYCLE
  ij = jj
  jp1 = j+1
  DO  i=jp1,n
    ij = ij+i-1
    w(i) = w(i) - v*a(ij)
  END DO
END DO

!        SET TI, TIM AND W
40 IF (ir <= 0) GO TO 45
IF (ti > zero) GO TO 50
IF (mk-1 > 0) THEN
  GO TO  55
ELSE
  GO TO  65
END IF

45 ti = zero
ir = -ir-1
GO TO 55

50 ti = eps/sig
IF (eps == zero) ir = ir-1
55 tim = ti
ii = jj
i = n
DO  j=1,n
  IF (a(ii) /= zero) tim = ti - (w(i)*w(i))/a(ii)
  w(i) = ti
  ti = tim
  ii = ii-i
  i = i-1
END DO
mm = 1
GO TO 70

65 mm = 0
tim = one/sig
70 jj = 0

!       UPDATE A
DO  j=1,n
  jj = jj+j
  ij = jj
  jp1 = j+1

!       UPDATE A(J,J)
  v = z(j)
  IF (a(jj) > zero) GO TO 85

!       A(J,J) .EQ. ZERO
  IF (ir > 0 .OR. sig < zero .OR. v == zero) GO TO 80
  ir = 1-ir
  a(jj) = (v*v)/tim
  IF (j == n) GO TO 9005
  DO  i=jp1,n
    ij = ij+i-1
    a(ij) = z(i)/v
  END DO
  GO TO 9005
  80 ti = tim
  CYCLE

!       A(J,J) .GT. ZERO
  85 al = v/a(jj)
  ti = w(j)
  IF (mm == 0) ti = tim + v*al
  r = ti/tim
  a(jj) = r*a(jj)
  IF (r == zero) EXIT
  IF (j == n) EXIT

!       UPDATE REMAINDER OF COLUMN J
  b = al/ti
  IF (r > four) GO TO 95
  DO  i=jp1,n
    ij = ij+i-1
    z(i) = z(i) - v*a(ij)
    a(ij) = a(ij) + b*z(i)
  END DO
  GO TO 105
  95 gm = tim/ti
  DO  i=jp1,n
    ij = ij+i-1
    y = a(ij)
    a(ij) = b*z(i) + y*gm
    z(i) = z(i) - v*y
  END DO
  105  tim = ti
END DO
IF (ir < 0) ir = -ir

9005 RETURN
END SUBROUTINE update

END MODULE global_minimum


      module random
        use, intrinsic :: iso_fortran_env, only : REAL64, INT16, INT32, INT64
        use, intrinsic :: iso_c_binding, only : C_INT128_T
      contains

        function random_real()
          ! Abstraction over rand(), in case I find a better option

          implicit none
          real(REAL64) random_real

          random_real = rand()
        end function random_real

        function random_von_Neumann()
          ! Gets a random number from the probability distribution
          ! for secondary electron energy, through von Neumann rejection

          implicit none

          real(REAL64) random_von_Neumann, r, E
          parameter(E=13)

          r = random_real()*300
          random_von_Neumann =  1/(1+(r/E)**2)
        end function random_von_Neumann

!         subroutine seed_rand()
!           ! Use MPI to find a representation of the wall time that changes
!           ! rapidly (increments every 1e-7 seconds) and use that as an
!           ! argument to srand()

!           implicit none

!           integer t
!           integer(C_INT128_T) bt

!           ! Get a high-precision time value from MPI, and shift it up so
!           ! that all significant digits are part of the integer truncation
!           bt = int(wtime()*1e7, C_INT128_T)
!           ! Truncate on the /left/ end of the big number, to get something
!           ! that varies quickly with time (i.e. varies as 1e-7 seconds)
!           ! Convert it to integer*4 so we can seed rand() with it
!           t = int(mod(bt, huge(t)), 4)

!           ! Use the rapidly-changing number as seed for rand()
!           call srand(t)
!         end subroutine seed_rand

        subroutine seed_rand_0()
          ! Call srand() with a constant seed, to be used for testing or
          ! producing reproducible simulation runs, but with a syntax
          ! similar to seed_rand() above.

          implicit none
          call srand(0)
        end subroutine seed_rand_0

      end module random


      subroutine ktsol(n,ns,nv,a,b,x,ktilt,maxeq)
c-----------------------------------------------------------------------
c
c Solution of a system of linear equations by gaussian elimination with
c partial pivoting.  Several right hand side matrices and several
c variables are allowed.
c
c
c         NOTE: All input matrices must be in double precision
c
c
c INPUT/OUTPUT VARIABLES:
c
c   n                Number of equations
c   ns               Number of right hand side matrices
c   nv               Number of variables.
c   a(n*n*nv)        left hand side matrices versus columnwise.
c   b(n*ns*nv)       input right hand side matrices.
c   x(n*ns*nv)       solution matrices.
c   ktilt            indicator of singularity
c                      =  0  everything is ok.
c                      = -1 n.le.1
c                      =  k  a null pivot appeared at the kth iteration.
c   tol              used in test for null pivot. depends on machine
c                      precision and can also be set for the tolerance
c                      of an ill-defined kriging system.
c
c
c-----------------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      real*8 x(maxeq),a(maxeq*maxeq),b(maxeq)
c
c Make sure there are equations to solve:
c
      if(n.le.1) then
            ktilt = -1
            return
      endif
c
c Initialization:
c
      tol   = 0.1e-10
      ktilt = 0
      ntn   = n*n
      nm1   = n-1
c
c Triangulation is done variable by variable:
c
      do iv=1,nv
c
c Indices of location in vectors a and b:
c
            nva = ntn*(iv-1)
            nvb = n*ns*(iv-1)
c
c Gaussian elimination with partial pivoting:
c
            do k=1,nm1
                  kp1 = k+1
c
c Indice of the diagonal element in the kth row:
c
                  kdiag = nva+(k-1)*n+k
c
c Find the pivot - interchange diagonal element/pivot:
c
                  npiv = kdiag
                  ipiv = k
                  i1   = kdiag
                  do i=kp1,n
                        i1 = i1+1
                        if(abs(a(i1)).gt.abs(a(npiv))) then
                              npiv = i1
                              ipiv = i
                        endif
                  end do
                  t        = a(npiv)
                  a(npiv)  = a(kdiag)
                  a(kdiag) = t
c
c Test for singularity:
c
                  if(abs(a(kdiag)).lt.tol) then
                        ktilt=k
                        return
                  endif
c
c Compute multipliers:
c
                  i1 = kdiag
                  do i=kp1,n
                        i1    = i1+1
                        a(i1) = -a(i1)/a(kdiag)
                  end do
c
c Interchange and eliminate column per column:
c
                  j1 = kdiag
                  j2 = npiv
                  do j=kp1,n
                        j1    = j1+n
                        j2    = j2+n
                        t     = a(j2)
                        a(j2) = a(j1)
                        a(j1) = t
                        i1    = j1
                        i2    = kdiag
                        do i=kp1,n
                              i1    = i1+1
                              i2    = i2+1
                              a(i1) = a(i1)+a(i2)*a(j1)
                        end do
                  end do
c
c Interchange and modify the ns right hand matrices:
c
                  i1 = nvb+ipiv
                  i2 = nvb+k
                  do i=1,ns
                        t     = b(i1)
                        b(i1) = b(i2)
                        b(i2) = t
                        j1    = i2
                        j2    = kdiag
                        do j=kp1,n
                              j1    = j1+1
                              j2    = j2+1
                              b(j1) = b(j1)+b(i2)*a(j2)
                        end do
                        i1 = i1+n
                        i2 = i2+n
                  end do
            end do
c
c Test for singularity for the last pivot:
c
            kdiag = ntn*iv
            if(abs(a(kdiag)).lt.tol) then
                  ktilt = n
                  return
            endif
      end do
c
c End of triangulation. Now, solve back variable per variable:
c
      do iv=1,nv
c
c Indices of location in vectors a and b:
c
            nva  = ntn*iv
            nvb1 = n*ns*(iv-1)+1
            nvb2 = n*ns*iv
c
c Back substitution with the ns right hand matrices:
c
            do il=1,ns
                  do k=1,nm1
                        nmk = n-k
c
c Indice of the diagonal element of the (n-k+1)th row and of
c the (n-k+1)th element of the left hand side.
c
                        kdiag = nva-(n+1)*(k-1)
                        kb    = nvb2-(il-1)*n-k+1
                        b(kb) = b(kb)/a(kdiag)
                        t     = -b(kb)
                        i1    = kb
                        i2    = kdiag
                        do i=1,nmk
                              i1    = i1-1
                              i2    = i2-1
                              b(i1) = b(i1)+a(i2)*t
                        end do
                  end do
                  kdiag = kdiag-n-1
                  kb    = kb-1
                  b(kb) = b(kb)/a(kdiag)
            end do
c
c End of back substitution:
c
      end do
c
c Restitution of the solution:
c
      itot = n*ns*nv
      do i=1,itot
            x(i) = b(i)
      end do
c
c Finished:
c
      return
      end