c
c
      subroutine mvmult(a,b,c,imax,jmax,nmax,m)
c
c*********************************************************************
c     Routine to compute the inner product of A B = C
c
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c
c*********************************************************************
c
      real a(m,m),b(m,m),c(m,m),sum
      integer imax,jmax,nmax,j,n,i,m
c
      do i=1,imax
      do n=1,nmax
         sum = 0.
         do j=1,jmax
            sum = sum + (a(i,j) * b(j,n))
         enddo !j
         c(i,n) = sum
      enddo !n
      enddo !i
c
      return
      end
c
c
      subroutine addmv(a,b,c,imax,jmax,m)
c
c*********************************************************************
c
c     Routine adds two vectors or matricies.  Results are output in c.
c
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c       13 Oct 1998  Peter Stamus, NOAA/FSL
c          Removed subract option...put in separate routine.
c
c*********************************************************************
c
      real a(m,m),b(m,m),c(m,m)
      integer imax,jmax,i,j,m
c
      do j=1,jmax
      do i=1,imax
         c(i,j) = a(i,j) + b(i,j)
      enddo !i
      enddo !j
c
      return
      end
c
c
      subroutine submv(a,b,c,imax,jmax,m)
c
c*********************************************************************
c
c     Routine subrtacts two vectors or matricies.  Results are output
c     in c.
c
c     Original: Peter Stamus, NOAA/FSL  13 Oct 1998 (from 'addmv')
c     Changes:
c
c*********************************************************************
c
      real a(m,m),b(m,m),c(m,m)
      integer imax,jmax,i,j,m
c
      do j=1,jmax
      do i=1,imax
         c(i,j) = a(i,j) - b(i,j)
      enddo !i
      enddo !j
c
      return
      end
c
c
      subroutine trans(a,at,imax,jmax,m)
c
c*********************************************************************
c     Routine creates the transposed matrix of a and places it in
c     the at array.
c
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c
c*********************************************************************
c
      real a(m,m),at(m,m)
      integer imax,jmax,i,j,m
c
      do j=1,jmax
      do i=1,imax
         at(i,j) = a(j,i)
      enddo !i
      enddo !j
c
      return
      end
c
c
      subroutine vomult(a,b,c,imax,m)
c
c*********************************************************************
c     Routine provides the outer product of two vectors a bt = c
c     matrix.
c
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c
c*********************************************************************
c
      real a(m),b(m),c(m,m)
      integer imax,j,i,m
c
      do j=1,imax
      do i=1,imax
         c(i,j) = a(i) * b(j)
      enddo !i
      enddo !j
c
      return
      end
c
c
      subroutine invert (a,n,np,y,maxsta)
c
c*********************************************************************
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c       14 Dec 1999  Peter Stamus, NOAA/FSL
c          Pass in max number of stations for 'ludcmp'.
c
c*********************************************************************
c
      real a(np,np),y(np,np),d
      integer np,indx(np),n,j,i
c
      do i=1,n
         do j=1,n
            y(i,j)=0.
         enddo !j
         y(i,i)=1.
      enddo !i
      call ludcmp(a,n,np,indx,d,maxsta)
      do j=1,n
         call lubksb(a,n,np,indx,y(1,j))
      enddo !j
c
      return
      end
c
      subroutine fastinv(A,imax,jmax,m)
      real A(m,m)
c     This inverts a matrix that is diagonal only
      if(imax.ne.jmax) print*,'matrix in fast invert is not square'
      print*,'Matrix to be inverted is diagonal...using fast invert'
      do j=1,jmax
        if(A(j,j).eq.0) then
         print*,' zero element in fast matrix inversion at ',j,j
         A(j,j)=1.e-30
        endif
        A(j,j)=1/A(j,j)
      enddo
      return
      end

c
      subroutine avgerr(wr,wit,B,c,W,dwt,imax,iav,m,it)
c
c*********************************************************************
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c       14 Dec 1999  John McGinley and Peter Stamus, NOAA/FSL
c          Add Bias error calculation.  Also some minor housekeeping.
c
c*********************************************************************
c
      real B(m),c(m,m),W(m,m),wit(m,m),wr(m),dwt(m,m)
c
      do l=m,2,-1
         do k=1,imax
            wit(l,k)=wit(l-1,k)
         enddo !k
      enddo !l
      do k=1,m
         wit(1,k)=wr(k)
      enddo !k
      do i=1,m
         do j=1,m
            W(i,j)=0.
         enddo !j
      enddo !i
      if(iav.gt.it) then
         ia=it
      else
         ia=iav
      endif
c
      sum = 0.
      cnt = 0.
      do itt=1,ia
         do i=1,m
            B(i)=wit(itt,i)
            sum = sum + B(i)
            cnt = cnt + 1.
         enddo !i
         do j=1,imax
            do i=1,imax
               C(i,j)=B(i)*B(j)*dwt(i,j)
            enddo !i
         enddo !j
        do j=1,imax
           do i=1,imax
              W(i,j)=W(i,j)+c(i,j)
           enddo !i
        enddo !j
      enddo !itt
      do j=1,imax
         do i=1,imax
            if(i.eq.j) then
               W(i,j)=W(i,j)/float(ia)
            else
               W(i,j)=W(i,j)/float(iav)
            endif
         enddo !i
      enddo !j
c
      if(cnt .gt. 0.) then
         write(6,*) ' Bias Error for W and VV: ', sum / cnt
      else
         write(6,*) ' In routine AVGERR: Cannot calculate bias ',
     &              ' error for W and VV -- cnt = 0'
      endif
c
      return
      end
c
c
      subroutine avgdiagerr(wit,B,c,W,imax,iav,m,it)
c
c*********************************************************************
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c       14 Dec 1999  John McGinley and Peter Stamus, NOAA/FSL
c          Add Bias error calculation.  Also some minor housekeeping.
c
c*********************************************************************
c
      real B(m),c(m,m),W(m,m),wit(m,m)
c
      call zero(W,m,m)
      ia=iav
      if(ia.gt.it) ia=it
c
      sum = 0.
      cnt = 0.
      do itt=1,ia
         do i=1,imax
            B(i)=wit(i,itt)
            sum = sum + B(i)
            cnt = cnt + 1.
         enddo !i
         do i=1,imax
            W(i,i)=W(i,i)+b(i)*b(i)
         enddo !i
      enddo !itt
      do i=1,imax
         W(i,i)=W(i,i)/float(ia)
      enddo !i
c
      if(cnt .gt. 0.) then
         write(6,*) ' Bias Error for W and VV: ', sum / cnt,' for ', ia
     & ,' cycles'
      else
         write(6,*) ' In routine AVGDIAGERR: Cannot calculate ',
     &              ' bias error for W and VV -- cnt = 0'
      endif
c
      return
      end
c
c
      subroutine matrixanal(a,imax,jmax,m,idiag,char)
c
c*********************************************************************
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c*********************************************************************
c
      real a(m,m)
      character char*10
c
      dimx=-1.e20
      dimn=1.e20
      elmx=-1.e20
      elmn=1.e20
c
c  diagonal element
c
      sumd=0.
      cnt=0.
      do j=1,jmax
         if(a(j,j).gt.dimx)dimx=a(j,j)
         if(a(j,j).lt.dimn)dimn=a(j,j)
         sumd=sumd+a(j,j)
         cnt=cnt+1.
      enddo !j
      sumd=sumd/cnt
c
c  remander of elements
c
      sumea=0.
      sume=0.
      cnt=0.
      do j=1,jmax
         do i=1,imax
            if (i.eq.j) go to 1
            if(a(i,j).gt.elmx) elmx=a(i,j)
            if(a(i,j).lt.elmn) elmn=a(i,j)
            sume=sume+a(i,j)
            sumea=sumea+abs(a(i,j))
            cnt=cnt+1.
 1       enddo !i
      enddo !j
      sume=sume/cnt
      sumea=sumea/cnt
c
c output results
c
      write(6,1000)  char
 1000 format(1x,'Diagnosis of matrix ',a10)
      write (6,1001) dimx,dimn
 1001 format(1x,'Max diagonal ',f8.3,' Min diagonal ',f8.3)
      write (6,1002) sumd
 1002 format(1x,'Avg diagonal ',f8.3)
      write (6,1003) elmx,elmn
 1003 format(1x,'Max non-diagonal ',f8.3,' Min non-diagonal ',f8.3)
      write (6,1004) sume
 1004 format(1x,'Avg non-diagonal ',f8.3)
      write (6,1005) sumea
 1005 format(1x,'Avg abs non-diagonal ',f8.3)
c
c flag matrix if it is purely diagonal
      if(elmx.eq.0..and.elmn.eq.0.) idiag=1
      return
      end
c
c
      Subroutine svdcmp(a,m,n,mp,np,w,v,nmax)
c
c*********************************************************************
c
c     Given a matrix a(m,n) with physical dimensions 'mp x np',
c     routine calculates a=u.w.vt. u repaces a on output
c     diagonal matrix of singular values w is output as a vector
c     v is output, not vtranspose.
c
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c       14 Dec 1999  Peter Stamus, NOAA/FSL
c          Pass in max number of stations as nmax.
c
c*********************************************************************
c
       integer m,mp,n,np,nmax
       integer i,its,j,jj,k,l,nm
       real a(mp,np),v(np,np),w(np)
       real anorm,c,f,g,h,s,scale,x,y,z,rv1(nmax),pythag
c
       g=0.
       scale=0.
       anorm=0.
       do i=1,n
          l=i+1
          rv1(i)=scale*g
          g=0.
          s=0.
          scale=0.
          if(i.le.m) then
             do k=i,m
                scale=scale+abs(a(k,i))
             enddo !on k
             if(scale.ne.0.) then
                do k=i,m
                   a(k,i)=a(k,i)/scale
                   s=s+a(k,i)*a(k,i)
                enddo !on k
                f=a(i,i)
                g=-sign(sqrt(s),f)
                h=f*g-s
                a(i,i)=f-g
                do j=l,n
                   s=0.
                   do k=i,m
                      s=s+a(k,i)*a(k,j)
                   enddo !on k
                   f=s/h
                   do k=i,m
                      a(k,j)=a(k,j)+f*a(k,i)
                   enddo !on k
                enddo !on j
                do k=i,m
                   a(k,i)=scale*a(k,i)
                enddo !on k
             endif
          endif
          w(i)=scale*g
          g=0.
          s=0.
          scale=0.
          if((i.le.m).and.(i.ne.n))then
             do k=l,n
                scale=scale+abs(a(i,k))
             enddo !on k
             if(scale.ne.0.)then
                do k=l,n
                   a(i,k)=a(i,k)/scale
                   s=s+a(i,k)*a(i,k)
                enddo !k
                f=a(i,l)
                g=-sign(sqrt(s),f)
                h=f*g-s
                a(i,l)=f-g
                do k=l,n
                   rv1(k)=a(i,k)/h
                enddo !on k
                do j=l,m
                   s=0.
                   do k=l,n
                      s=s+a(j,k)*a(i,k)
                   enddo !on k
                   do k=l,n
                      a(j,k)=a(j,k)+s*rv1(k)
                   enddo !on k
                enddo !on j
                do k=l,n
                   a(i,k)=scale*a(i,k)
                enddo !on k
             endif
          endif
          anorm=max(anorm,(abs(w(i))+abs(rv1(i))))
       enddo !on i
       do i=n,1,-1
          if(i.lt.n)then
             if(g.ne.0.)then
                do j=l,n
                   v(j,i)=(a(i,j)/a(i,l))/g
                enddo !on j
                do j=l,n
                   s=0.
                   do k=l,n
                      s=s+a(i,k)*v(k,j)
                   enddo !on k
                   do k=l,n
                      v(k,j)=v(k,j)+s*v(k,i)
                   enddo !on k
                enddo !on j
             endif
             do j=l,n
                v(i,j)=0.
                v(j,i)=0.
             enddo !j
          endif
          v(i,i)=1.
          g=rv1(i)
          l=i
       enddo !on i
       do i=min(m,n),1,-1
          l=i+1
          g=w(i)
          do j=l,n
             a(i,j)=0.
          enddo ! on j
          if(g.ne.0.) then
             g=1./g
             do j=l,n
                s=0.
                do k=l,m
                   s=s+a(k,i)*a(k,j)
                enddo !on k
                f=(s/a(i,i))*g
                do k=i,m
                   a(k,j)=a(k,j)+f*a(k,i)
                enddo !on k
             enddo !on j
             do j=i,m
                a(j,i)=a(j,i)*g
             enddo !j
          else
             do j=i,m
                a(j,i)=0.
             enddo !on j
          endif
          a(i,i)=a(i,i)+1.
       enddo ! on i
       do k=n,1,-1
          do its=1,30
             do l=k,1,-1
                nm=l-1
                if((abs(rv1(l))+anorm).eq.anorm) go to 2
                if((abs(w(nm)+anorm)).eq.anorm) go to 1
             enddo !on l
 1           c=0.
             s=1.
             do i=l,k
                f=s*rv1(i)
                rv1(i)=c*rv1(i)
                if((abs(f)+anorm).eq.anorm) go to 2
                g=w(i)
                h=pythag(f,g)
                w(i)=h
                h=1./h
                c=(g*h)
                s=-(f*h)
                do j=1,m
                   y=a(j,nm)
                   z=a(j,i)
                   a(j,nm)=(y*c)+(z*s)
                   a(j,i)=-(y*s)+(z*c)
                enddo !on j
             enddo !on i
 2           z=w(k)
             if(l.eq.k) then
                if(z.lt.0.) then
                   w(k)=-z
                   do j=1,n
                      v(j,k)=-v(j,k)
                   enddo ! on j
                endif
                go to 3
             endif
             if(its.eq.30) then
                print *,
     &       ' No convergence in sudcmp: inverted matrix may be suspect'
             endif
             x=w(l)
             nm=k-1
             y=w(nm)
             g=rv1(nm)
             h=rv1(k)
             f=((y-z)*(y+z)+(g+h)*(g-h))/(2.*h*y)
             g=pythag(f,1.)
             f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
             c=1.
             s=1.
             do j=l,nm
                i=j+1
                g=rv1(i)
                y=w(i)
                h=s*g
                g=c*g
                z=pythag(f,h)
                rv1(j)=z
                c=f/z
                s=h/z
                f=(x*c)+(g*s)
                g=-(x*s)+(g*c)
                h=y*s
                y=y*c
                do jj=1,n
                   x=v(jj,j)
                   z=v(jj,i)
                   v(jj,j)=(x*c)+(z*s)
                   v(jj,i)=-(x*s)+(z*c)
                enddo !on jj
                z=pythag(f,h)
                w(j)=z
                if(z.ne.0.) then
                   z=1./z
                   c=f*z
                   s=h*z
                endif
                f=(c*g)+(s*y)
                x=-(s*g)+(c*y)
                do jj=1,m
                   y=a(jj,j)
                   z=a(jj,i)
                   a(jj,j)=(y*c)+(z*s)
                   a(jj,i)=-(y*s)+(z*c)
                enddo !on jj
             enddo !on j
             rv1(l)=0.
             rv1(k)=f
             w(k)=x
          enddo !on its
 3        continue
       enddo ! on k
c
       return
       end
c
c
        Subroutine svbksb(u,w,v,m,n,mp,np,b,x,nmax)
c
c*********************************************************************
c
c     This subroutine solves A.X=B for X where A is specified by
c     arrays u,w,v from svdcmp.
c
c     Original: John McGinley, NOAA/FSL  Spring 1998
c     Changes:
c       21 Aug 1998  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c       14 Dec 1999  Peter Stamus, NOAA/FSL
c          Pass in max number of stations as nmax.
c
c*********************************************************************
c
        integer i,j,jj
        integer m,mp,n,np,nmax
        real s,tmp(nmax)
        real b(mp),u(mp,np),v(np,np),w(np),x(np)
c
        do j=1,n
           s=0.
           if(w(j).ne.0.) then
              do i=1,m
                 s=s+u(i,j)*b(i)
              enddo !i
              s=s/w(j)
           endif
           tmp(j)=s
        enddo !j
        do j=1,n
           s=0.
           do jj=1,n
              s=s+v(j,jj)*tmp(jj)
           enddo !jj
           x(j)=s
        enddo !on j
c
        return
        end
c
c
      subroutine ludcmp(a,n,np,indx,d,nmax)
c
c*********************************************************************
c
c     This subroutine performs lower/upper decomposition of a
c     matrix "a".
c
c     Original: John McGinley, NOAA/FSL  December 1999
c     Changes:
c       14 Dec 1999  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c
c*********************************************************************
c
      real d,a(np,np),tiny
      real aamax,dum,sum,vv(nmax)
      integer i,imax,j,k
      integer n,np,indx(n),nmax
      parameter (tiny=1.e-20)
c
      d=1.
      do i=1,n
         aamax=0.
         do j=1,n
            if(abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))
         enddo !j
         if(aamax.eq.0.) then
            print *, 'All 0, singular matrix in ludcmp'
         endif
         vv(i)=1./aamax
      enddo !i
c
      do j=1,n
         do i=1,j-1
            sum=a(i,j)
            do k=1,i-1
               sum=sum-a(i,k)*a(k,j)
            enddo !k
            a(i,j)=sum
         enddo !i
         aamax=0.
         do i=j,n
            sum=a(i,j)
            do k=1,j-1
               sum=sum-a(i,k)*a(k,j)
            enddo !k
            a(i,j)=sum
            dum=vv(i)*abs(sum)
            if(dum.ge.aamax) then
               imax=i
               aamax=dum
            endif
         enddo !i
         if(j.ne.imax) then
            do k=1,n
               dum=a(imax,k)
               a(imax,k)=a(j,k)
               a(j,k)=dum
            enddo !k
            d=-d
            vv(imax)=vv(j)
         endif
         indx(j)=imax
         if(a(j,j).eq.0.)a(j,j)=tiny
         if(j.ne.n)then
            dum=1./a(j,j)
            do i=j+1,n
               a(i,j)=a(i,j)*dum
            enddo !i
         endif
      enddo !j
c
      return
      end
c
c
      subroutine lubksb(a,n,np,indx,b)
c
c*********************************************************************
c
c     This subroutine solves a set of 'n' linear equationsns (a.x=b).
c
c     Original: John McGinley, NOAA/FSL  December 1999
c     Changes:
c       14 Dec 1999  Peter Stamus, NOAA/FSL
c          Make code dynamic, housekeeping changes, for use in LAPS.
c
c*********************************************************************
c
      integer i,ii,j,ll
      integer n,np,indx(n)
      real a(np,np),b(n)
      real sum
c
      ii=0
      do i=1,n
         ll=indx(i)
         sum=b(ll)
         b(ll)=b(i)
         if(ii.ne.0) then
            do j=ii,i-1
               sum=sum-a(i,j)*b(j)
            enddo !j
         elseif(sum.ne.0.) then
            ii=i
         endif
         b(i)=sum
      enddo !i
c
      do i=n,1,-1
         sum=b(i)
         do j=i+1,n
            sum=sum-a(i,j)*b(j)
         enddo !j
         b(i)=sum/a(i,i)
      enddo !i
c
      return
      end


#define FHASH_NAME i2char
#define KEY_TYPE integer
#define VALUE_TYPE character(10)
#include "fhash.f90"

! Define the module for the key type.
module ints_module

  implicit none

  type ints_type
    integer, allocatable :: ints(:)
  end type

  interface hash_value
    module procedure hash_value_ints
  end interface

contains

  function hash_value_ints(ints) result(hash)
    use, intrinsic :: iso_fortran_env, only: int64, real64
    type(ints_type), intent(in) :: ints
    integer(kind(ints%ints)) :: hash

    real(real64), parameter :: phi = (sqrt(5.0_real64) + 1) / 2
    ! Do not use `nint` intrinsic, because ifort claims that  "Fortran 2018 specifies that
    ! "an elemental intrinsic function here be of type integer or character and
    !  each argument must be an initialization expr of type integer or character":
    integer, parameter :: magic_number = 0.5d0 + 2.0d0**bit_size(hash) * (1 - 1 / phi)
    integer :: i

    hash = 0
    do i = 1, size(ints%ints)
      ! This triggers an error in `gfortran` (version 9.3.0) with the `-ftrapv` option.
      ! Compiler bug?
      hash = ieor(hash, ints%ints(i) + magic_number + ishft(hash, 6) + ishft(hash, -2))
    enddo
  end function

  function ints_equal(lhs, rhs)
    type(ints_type), intent(in) :: lhs, rhs
    logical :: ints_equal
    integer :: i

    if (size(lhs%ints) /= size(rhs%ints)) then
      ints_equal = .false.
      return
    endif

    do i = 1, size(lhs%ints)
      if (lhs%ints(i) /= rhs%ints(i)) then
        ints_equal = .false.
        return
      endif
    enddo

    ints_equal = .true.

  end function
end module ints_module

! Define the macros needed by fhash and include fhash.f90
#define FHASH_NAME ints_double
#define KEY_USE use ints_module
#define KEY_TYPE type(ints_type)
#define KEYS_EQUAL_FUNC ints_equal
#define VALUE_USE use, intrinsic :: iso_fortran_env
#define VALUE_TYPE real(real64)
#define HASH_FUNC hash_value
#define VALUE_TYPE_INIT 0.0
#include "fhash.f90"

! Define the macros needed by fhash and include fhash.f90
#define FHASH_NAME int_ints_ptr
#define KEY_TYPE integer
#define VALUE_USE use ints_module
#define VALUE_TYPE type(ints_type), pointer
!#define VALUE_TYPE_INIT null()
#define VALUE_POINTER
#ifdef VALUE_TYPE_INIT
#define CHECK_ITERATOR_VALUE
#endif
#include "fhash.f90"


module utilities
    !! Useful procedures when doing percolation.
    implicit none
    integer, parameter :: dp = kind(1.0d0)
        !! Kind used for all **real** variables.
    contains
        function stringfromint(x)
            !! Make a string of "correct" length from a positive integer.
            character(len=:), allocatable :: stringfromint
                !! String containing the given integer, without spaces.
            integer, intent(in) :: x
                !! Positive integer to be converted.
            integer :: numdigits

            numdigits = int(log10(real(x))) + 1
            allocate(character(len=numdigits) :: stringfromint)
            write(unit=stringfromint, fmt="(i0)") x
        end function

        function linspace(a,b,N)
            !! Create an array of **N** linearly spaced *values* (not intervals)
            !! from **a** to **b**.
            !! Similar to [`numpy.linspace(a, b, N)`](https://docs.scipy.org/doc/numpy/reference/generated/numpy.linspace.html).
            integer, intent(in) :: N
                !! Number of values (not intervals).
            real(kind=dp), intent(in) :: a
                !! Lower endpoint.
            real(kind=dp), intent(in) :: b
                !! Upper endpoint.
            real(kind=dp), dimension(:), allocatable :: linspace
                !! Array of linearly spaced values.
            real(kind=dp) :: dx
            integer :: i

            dx = (b - a)/(N - 1)
            linspace = [ (a + i*dx, i=0, N-1) ]
        end function

        subroutine linfit(x, y, slope, const)
            !! Compute a linear fit for the given data, return
            !! the slope and the constant term.
            !! `dgels` from LAPACK solves the linear least squares problem.
            real(kind=dp), dimension(:), intent(in) :: x, y
                !! Values to be fitted.
            real(kind=dp), intent(inout) :: slope
                !! \\(a\\) in \\(y=ax+b\\).
            real(kind=dp), intent(inout) :: const
                !! \\(b\\) in \\(y=ax+b\\).

            real(kind=dp), dimension(:,:), allocatable :: A
            real(kind=dp), dimension(:), allocatable :: b, work
            integer :: lda, ldb, lwork, info, m

            m = size(x)
            allocate(A(m,2))
            allocate(b(m))
            allocate(work(1))

            A(:,1) = x(:)
            A(:,2) = 1
            b(:) = y(:)

            lda = m
            ldb = m

            lwork = -1
            call dgels("N",m,2,1,A,lda,b,ldb,work,lwork,info)
            lwork = int(work(1))
            deallocate(work)
            allocate(work(lwork))
            call dgels("N",m,2,1,A,lda,b,ldb,work,lwork,info)

            slope = b(1)
            const = b(2)

            if(info /= 0) then
                error stop "Problems with least squares"
            endif
        end subroutine

        function find_intersection(array1, array2, num_labels) result(intersect_label)
            !! Find the common element in two arrays, given a total of
            !! **num_labels** unique elements. Used by [[find_spanning_cluster]].
            integer, dimension(:), intent(in) :: array1, array2
                !! Array to analyse.
            integer, intent(in) :: num_labels
                !! The known number of unique non-zero elements.
            integer :: intersect_label
                !! The first non-zero common element.
            integer :: L, i
            logical, dimension(:), allocatable :: label_found

            L = size(array1)

            allocate(label_found(0:num_labels))
            !/intersectsnippetstart/!
            label_found(0:num_labels) = .false.

            do i=1,L
                label_found(array1(i)) = .true.
            end do

            do i=1,L
                if(array2(i) /= 0 .and. label_found(array2(i))) then
                    intersect_label = array2(i)
                    return
                end if
            end do
            !/intersectsnippetend/!

            intersect_label = -1
        end function

        subroutine find_random_point(matrix, i, j)
            !! Find a random position on **matrix** such that
            !! **matrix(i, j)** is `.true.`.

            logical, dimension(:,:), intent(in) :: matrix
                !! Matrix whose `.true.` values are allowed positions for the
                !! random walker.

            integer, intent(out) :: i, j
                !! Returned random point on **matrix**.

            integer :: L
            real(kind=dp) :: x0_real, y0_real

            L = size(matrix, 1)

            ! Find random starting point.
            do
                call random_number(x0_real)
                call random_number(y0_real)

                x0_real = L*x0_real + 1
                y0_real = L*y0_real + 1

                i = int(x0_real)
                j = int(y0_real)

                if(matrix(i,j)) then
                    return
                end if
            end do
        end subroutine

        subroutine periodic_wraparound(x, L)
            integer, intent(inout) :: x
            integer, intent(in) :: L

            if(x == 0) then
                !write(*,*) "before:", x
                x = L
                !write(*,*) "after:", x
            else if(x == L+1) then
                !write(*,*) "before:", x
                x = 1
                !write(*,*) "after:", x
            end if
        end subroutine

        function mark_percolating_with_periodic(label_matrix, &
                                                percolating_label, &
                                                num_clusters) &
                                                result(matrix)
            !! Return a `logical` matrix where the `.true.` values are the sites
            !! belonging to the percolating cluster, when periodic boundary
            !! conditions are considered.

            integer, dimension(:,:), intent(in) :: label_matrix
                !! Labelled matrix from [[label]] or [[hoshen_kopelman]].
            integer, intent(in) :: percolating_label
                !! Known label of the percolating cluster.
            integer, intent(in) :: num_clusters
                !! The known number of clusters.
            logical, dimension(:,:), allocatable :: matrix
                !! Matrix where the `.true.` values are the sites belonging to
                !! the percolating cluster with periodic boundary conditions.

            integer :: L, i, j
            logical, dimension(:), allocatable :: connected_to_percolating

            L = size(label_matrix, 1)

            allocate(matrix(L,L))
            allocate(connected_to_percolating(0:num_clusters))

            connected_to_percolating(:) = .false.
            connected_to_percolating(percolating_label) = .true.

            do i = 1, L
                if(label_matrix(i,1) == percolating_label) then
                    connected_to_percolating(label_matrix(i, L)) = .true.
                end if

                if(label_matrix(i,L) == percolating_label) then
                    connected_to_percolating(label_matrix(i, 1)) = .true.
                end if

                if(label_matrix(1,i) == percolating_label) then
                    connected_to_percolating(label_matrix(L, i)) = .true.
                end if

                if(label_matrix(L, i) == percolating_label) then
                    connected_to_percolating(label_matrix(1, i)) = .true.
                end if
            end do

            connected_to_percolating(0) = .false.

            !$omp parallel do
            do j = 1, L
                do i = 1, L
                    matrix(i,j) = connected_to_percolating(label_matrix(i,j))
                end do
            end do
            !$omp end parallel do
        end function
end module


! { dg-do run }
! { dg-options "-std=f2008 " }

! Test for correct semantics of implied-shape arrays.

! Contributed by Daniel Kraft, d@domob.eu.

PROGRAM main
  IMPLICIT NONE

  INTEGER, PARAMETER :: n = 3

  ! Should be able to reduce complex expressions.
  REAL, PARAMETER :: arr1(n:*) = SQRT ((/ 1.0, 2.0, 3.0 /)) + 42

  ! With dimension statement.
  REAL, DIMENSION(*), PARAMETER :: arr2 = arr1

  ! Rank > 1.
  INTEGER, PARAMETER :: arr3(n:*, *) = RESHAPE ((/ 1, 2, 3, 4 /), (/ 2, 2/))

  ! Character array.
  CHARACTER(LEN=*), PARAMETER :: arr4(*) = (/ CHARACTER(LEN=3) :: "ab", "cde" /)

  IF (LBOUND (arr1, 1) /= n .OR. UBOUND (arr1, 1) /= n + 2) STOP 1
  IF (SIZE (arr1) /= 3) STOP 2

  IF (LBOUND (arr2, 1) /= 1 .OR. UBOUND (arr2, 1) /= 3) STOP 3
  IF (SIZE (arr2) /= 3) STOP 4

  IF (ANY (LBOUND (arr3) /= (/ n, 1 /) .OR. UBOUND (arr3) /= (/ n + 1, 2 /))) &
    STOP 5
  IF (SIZE (arr3) /= 4) STOP 6

  IF (LBOUND (arr4, 1) /= 1 .OR. UBOUND (arr4, 1) /= 2) STOP 7
  IF (SIZE (arr4) /= 2) STOP 8
END PROGRAM main


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
! PR 52243 - avoid check for reallocation when doing simple
! assignments with the same variable on both sides.
module  foo
contains
  elemental function ele(a)
    real, intent(in) :: a
    real :: ele
    ele = 1./(2+a)
  end function ele

  subroutine bar(a)
    real, dimension(:), allocatable :: a
    a = a * 2.0
    a = sin(a-0.3)
    a = ele(a)
  end subroutine bar
end module foo
! { dg-final { scan-tree-dump-times "alloc" 0 "original" } }


!!*------------------------------------------------------------------*!!
!!  Project : mfpDataStructure
!!*------------------------------------------------------------------*!!
!!
!!  Fortran Module
!!      General
!!
!!  Description
!!      FyMC Pack General Module
!!
!!  Authors
!!      YoungMyung Choi, Ecole Centrale de Nantes
!!          - youngmyung.choi@ec-nantes.fr
!!
!!*------------------------------------------------------------------*!!

!! ------------------------------------------------------------------ !!
!!  Module : FyMcPack Module General
!! ------------------------------------------------------------------ !!
Module  mfpGeometry

!!  Dependency ------------------------------------------------------ !!

    use mfpGlobal
    use mfpGeneral

!!  Variable Declaration -------------------------------------------- !!

Implicit None

private

!!  Module Variable ------------------------------------------------- !!

    Include "../mathConstant/gaussQuadrature.inc"

!!  Header Files ---------------------------------------------------- !!

    Include "baseGeometry/point.typ"

    Include "baseGeometry/panel.typ"

    Include "surfMesh/surfMesh.typ"

    !! Public

    Public :: testSurfMesh

Contains

!!  Procedure Files ------------------------------------------------- !!

    Include "auxiliary/getGaussCoordinate.inc"

    Include "baseGeometry/point.inc"

    Include "baseGeometry/panel.inc"

    Include "surfMesh/surfMesh.inc"

!!  Subroutine Test Script ------------------------------------------ !!

    Include "surfMesh/testSurfMesh.inc"

End Module


PROGRAM matrixMultiply

    use nvtx

    IMPLICIT NONE

    INTEGER, PARAMETER :: N = 2 ** 7

    REAL(KIND=8), ALLOCATABLE, DIMENSION(:, :) :: A, B, C
    REAL(KIND=8) :: tmp
    INTEGER :: i, j, k

    call nvtxStartRange("MAIN")

    allocate (A(N, N), B(N, N), C(N, N))

    CALL RANDOM_NUMBER(A)
    CALL RANDOM_NUMBER(B)

    call nvtxStartRange("ACC INIT")
    !$acc init
    call nvtxEndRange

    call nvtxStartRange("WARMUP")
    !$acc parallel num_gangs(N) vector_length(N)
    !$acc loop
    DO i=1, N
        DO j=1, N
            tmp = 0.0_8
            DO k=1, N
                tmp = tmp + A(i, k) * B(k, j)
            END DO
            C(i, j) = tmp
        END DO
    END DO
    !$acc end parallel
    call nvtxEndRange

    call verify(A, B, C, N)

    call nvtxStartRange("ver1: gang-vector, none, none")
    !$acc parallel num_gangs(N) vector_length(N)
    !$acc loop gang vector
    DO i=1, N
        DO j=1, N
            tmp = 0.0_8
            DO k=1, N
                tmp = tmp + A(i, k) * B(k, j)
            END DO
            C(i, j) = tmp
        END DO
    END DO
    !$acc end parallel
    call nvtxEndRange

    call verify(A, B, C, N)

    call nvtxStartRange("ver2: gang, none, vector")
    !$acc parallel num_gangs(N) vector_length(N)
    !$acc loop gang
    DO i=1, N
        DO j=1, N
            tmp = 0.0_8
            !$acc loop vector
            DO k=1, N
                tmp = tmp + A(i, k) * B(k, j)
            END DO
            C(i, j) = tmp
        END DO
    END DO
    !$acc end parallel
    call nvtxEndRange

    call verify(A, B, C, N)

    call nvtxStartRange("ver3: gang(collapse), none, vector")
    !$acc parallel vector_length(N)
    !$acc loop gang collapse(2)
    DO i=1, N
        DO j=1, N
            tmp = 0.0_8
            !$acc loop vector
            DO k=1, N
                tmp = tmp + A(i, k) * B(k, j)
            END DO
            C(i, j) = tmp
        END DO
    END DO
    !$acc end parallel
    call nvtxEndRange

    call verify(A, B, C, N)

    call nvtxStartRange("ver4: gang(collapse), none, vector independent")
    !$acc parallel vector_length(N)
    !$acc loop gang collapse(2)
    DO i=1, N
        DO j=1, N
            tmp = 0.0_8
            !$acc loop vector independent
            DO k=1, N
                tmp = tmp + A(i, k) * B(k, j)
            END DO
            C(i, j) = tmp
        END DO
    END DO
    !$acc end parallel
    call nvtxEndRange

    call verify(A, B, C, N)

    call nvtxStartRange("ver5: gang vector tile(8, 8), none, none")
    !$acc parallel
    !$acc loop gang vector tile(8, 8)
    DO i=1, N
        DO j=1, N
            tmp = 0.0_8
            DO k=1, N
                tmp = tmp + A(i, k) * B(k, j)
            END DO
            C(i, j) = tmp
        END DO
    END DO
    !$acc end parallel
    call nvtxEndRange

    call verify(A, B, C, N)

    call nvtxStartRange("ver6: gang vector independent tile(8, 8), none, none")
    !$acc parallel
    !$acc loop gang vector independent tile(8,8)
    DO i=1, N
        DO j=1, N
            tmp = 0.0_8
            DO k=1, N
                tmp = tmp + A(i, k) * B(k, j)
            END DO
            C(i, j) = tmp
        END DO
    END DO
    !$acc end parallel
    call nvtxEndRange

    call verify(A, B, C, N)

    deallocate (A, B, C)

    call nvtxEndRange

CONTAINS

    SUBROUTINE verify(A, B, C, N)
        REAL(KIND=8), ALLOCATABLE, INTENT(IN), DIMENSION(:, :) :: A, B, C
        INTEGER, INTENT(IN) :: N
        REAL(KIND=8) :: tmp
        INTEGER :: i, j, k

        DO i=1, N
            DO j=1, N
                tmp = 0.0_8
                DO k=1, N
                    tmp = tmp + A(i, k) * B(k, j)
                END DO

                IF ( ABS(C(i, j) - tmp) .GT. 1.0E-13_8 ) THEN
                    PRINT *, C(i, j), ".NE.", tmp
                    STOP
                END IF
            END DO
        END DO

        print *, "Verified"

    END SUBROUTINE

END PROGRAM


c=======================================================================
c
c     subroutine GREPS
c
c     Computing groups in a sorted vector for a sensibility
c
c-----------------------------------------------------------------------
      SUBROUTINE greps ( N, X, eps, NG, XG, info )
c-----------------------------------------------------------------------
c
c     INPUT
c        N    : size of the vector                               integer
c        X(N) : input vector (N), in decrease order               double
c        eps  : groups sensibility                                double
c
c     OUTPUT
c        NG   : number of groups                                 integer
c        XG   : groups vector (NG), max = N                      integer
c        info : diagnostic argument                              integer
c
c     METHOD
c            for an example of vector ( N = 7 ) :
c            X = [ 5.2, 5.1, 3.5, 3.4, 3.3, 1.7 1.3 ]
c            and eps = 0.15, the routine computes
c            NG = 4 and XG = [ 2, 3, 1, 1 ]
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o parameters
      INTEGER N, NG, info, XG(*)
      DOUBLE PRECISION eps, X(*)
c
c     local variables
      INTEGER i
c
c     intrinsic functions
      INTRINSIC ABS
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     one group by default
      NG = 1
      XG(NG) = 1
c
c     loop
      DO i = 2,N
         IF ( ABS( X(i) - X(i - 1) ) .LT. eps ) THEN
            XG(NG) = XG(NG) + 1
         ELSE
            NG = NG + 1
            XG(NG) = 1
         ENDIF
      ENDDO
      RETURN
      END


module newton

implicit none

type, abstract :: newtoncallback
contains
    procedure(dpfunc), deferred :: func
    procedure(dpfunc), deferred :: deriv
end type newtoncallback

abstract interface
    function dpfunc(this, x) result(fx)
        import :: newtoncallback
        class(newtoncallback), intent(in) :: this
        double precision, intent(in) :: x
        double precision :: fx
    end function dpfunc
end interface

contains

double precision function newtonsolver(cb, x0, maxiter, tol)
    class(newtoncallback), intent(in) :: cb
    double precision, intent(in) :: x0
    integer, intent(in), optional :: maxiter
    double precision, intent(in), optional :: tol

    integer :: maxiter_
    double precision :: tol_

    integer :: i
    double precision :: p
    double precision :: p0

    p0 = x0
    maxiter_ = 50
    if (present(maxiter)) maxiter_ = maxiter
    tol_ = 1d-8
    if (present(tol)) tol_ = tol

    do i = 1, maxiter_
        p = p0 - cb%func(p0) / cb%deriv(p0)
        if (abs(p - p0) < tol_) then
            newtonsolver = p
            return
        end if
        p0 = p
    end do

    write(*,*) "Not converged."
    stop 1
end function newtonsolver

end module newton


module module_twosat
  use, intrinsic :: iso_fortran_env
  use strongly_connected_component
  implicit none
  type twosat
    integer(int32), private :: n
    logical, private, allocatable :: ans(:)
    type(scc_graph), private :: scc
  contains
    procedure :: add_clause => add_clause
    procedure :: satisfiable => satisfiable
    procedure :: answer => answer
  end type
  interface twosat
    module procedure :: new_twosat
  end interface
contains
  type(twosat) function new_twosat(n) result(res)
    integer(int32), intent(in) :: n
    res%n = n
    allocate(res%ans(n))
    res%ans = .false.
    res%scc = new_scc_graph(2 * n)
  end
  subroutine add_clause(this, i, f, j, g)
    class(twosat), intent(inout) :: this
    integer(int32), intent(in) :: i, j
    logical, intent(in) :: f, g
    call add_edge(this%scc, &
      2 * i - 1 + merge(0, 1, f), 2 * j - 1 + merge(1, 0, g))
    call add_edge(this%scc, &
      2 * j - 1 + merge(0, 1, g), 2 * i - 1 + merge(1, 0, f))
  end
  logical function satisfiable(this) result(res)
    class(twosat), intent(inout) :: this
    type(array_list) :: id
    integer(int32) :: i
    res = .false.
    id = scc_ids(this%scc)
    do i = 1, this%n
      if (id%array(2 * i - 1) == id%array(2 * i)) return
      this%ans(i) = id%array(2 * i - 1) < id%array(2 * i)
    end do
    res = .true.
  end
  function answer(this) result(res)
    class(twosat), intent(in) :: this
    logical :: res(this%n)
    res = this%ans
  end
end module


!======================================================================!
  subroutine GradP(grid, phi, phi_x, phi_y, phi_z)
!----------------------------------------------------------------------!
! Calculates gradient of generic variable phi. phi may stand either    !
! for pressure (P) or pressure corrections (PP). This procedure also   !
! handles different materials.                                         !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  use all_mod
  use pro_mod
  use Grid_Mod
!----------------------------------------------------------------------!
  implicit none
!-----------------------------[Arguments]------------------------------!
  type(Grid_Type) :: grid
  real            :: phi  (-grid % n_bnd_cells:grid % n_cells),  &
                     phi_x(-grid % n_bnd_cells:grid % n_cells),  &
                     phi_y(-grid % n_bnd_cells:grid % n_cells),  &
                     phi_z(-grid % n_bnd_cells:grid % n_cells)
!-------------------------------[Locals]-------------------------------!
  integer :: s, c, c1, c2, iter
!======================================================================!

  call Exchange(grid, phi)

  do c = 1, grid % n_cells
    phi_x(c)=0.0
    phi_y(c)=0.0
    phi_z(c)=0.0
  end do

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(c2 < 0 .and. TypeBC(c2) /= BUFFER) then
      if(TypeBC(c2) /= PRESSURE) then
        phi(c2) = phi(c1)
      end if
    end if
  end do

  call GraPhi(grid, phi, 1, phi_x, .TRUE.)  ! dP/dx
  call GraPhi(grid, phi, 2, phi_y, .TRUE.)  ! dP/dy
  call GraPhi(grid, phi, 3, phi_z, .TRUE.)  ! dP/dz

  do iter=1,1

    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)
      if(c2 < 0 .and. TypeBC(c2) /= BUFFER) then
        if(TypeBC(c2) /= PRESSURE) then
          phi(c2) = phi(c1) + 1.2 * ( phi_x(c1) * (grid % xc(c2)-grid % xc(c1)) &
                            +         phi_y(c1) * (grid % yc(c2)-grid % yc(c1)) &
                            +         phi_z(c1) * (grid % zc(c2)-grid % zc(c1)) )
        end if
      end if
    end do

    call GraPhi(grid, phi, 1, phi_x, .TRUE.)  ! dP/dx
    call GraPhi(grid, phi, 2, phi_y, .TRUE.)  ! dP/dy
    call GraPhi(grid, phi, 3, phi_z, .TRUE.)  ! dP/dz

  end do

  end subroutine


module Task
use mpi
implicit none

contains

     subroutine GetMaxCoordinates(A, x1, y1, x2, y2) ! Процедура нахождения координат максимальной подматрицы
     implicit none

     ! Входные и выходные данные
     real(8), dimension(:,:), intent(in) :: A
     integer(4), intent(out) :: x1, y1, x2, y2

     ! Переменные для работы алгоритма Кадане
     integer(4) L, R, Up, Down
     integer(4) n, m, tmp
     real(8), allocatable :: current_column(:), B(:,:)
     real(8) current_sum
     real(8) max_sum
     logical transpos

     ! Вспомогательные переменные
     integer ier

     ! Вспомогательные переменные MPI
     integer(4) mpiErr, mpiSize, mpiRank
     integer(4) ierr

     ! Переменные для определения результата
     real(8), allocatable, dimension(:) :: max_sum_array ! Максимальное значение max_sum и ранг процесса, который его нашёл
     integer(4) max_rank ! Ранг процесса, который нашел максимальное значение max_sum

     m = size(A, dim=1)
     n = size(A, dim=2)
     transpos = .FALSE.

     if (m .lt. n) then
          transpos = .TRUE.

          B = transpose(A)
          m = size(B, dim=1)
          n = size(B, dim=2)
     else
          B = A
     endif

     call mpi_comm_size(MPI_COMM_WORLD, mpiSize, mpiErr)
     call mpi_comm_rank(MPI_COMM_WORLD, mpiRank, mpiErr)

     max_sum = B(1,1)
     x1 = 1
     y1 = 1
     x2 = 1
     y2 = 1

     ! Работа процесса над своей порцией

     allocate(current_column(m), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива current_column'

     do L = mpiRank + 1, n, mpiSize
          current_column = B(:, L)
          do R = L, n
               if (R .gt. L) then
                    current_column = current_column + B(:, R)
               endif

               call FindMaxInArray(current_column, current_sum, Up, Down)

               if (current_sum .gt. max_sum) then
                    max_sum = current_sum
                    x1 = Up
                    x2 = Down
                    y1 = L
                    y2 = R
               endif
          end do
     end do

     deallocate(current_column)

     ! Определение ранга процесса с максимальным значением max_sum

     allocate(max_sum_array(mpiSize), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива max_sum_array'

     call mpi_gather(max_sum, 1, MPI_REAL8, max_sum_array, 1, MPI_REAL8, 0, MPI_COMM_WORLD, ierr)

     if (mpiRank .eq. 0) then
          max_rank = maxloc(max_sum_array, dim = 1)
          max_rank = max_rank - 1
     endif

     call mpi_bcast(max_rank, 1, MPI_INTEGER4, 0, MPI_COMM_WORLD, ierr)

     deallocate(max_sum_array)

     ! Сообщение другим процессам результатов

     call mpi_bcast(x1, 1, MPI_REAL8, max_rank, MPI_COMM_WORLD, ierr)
     call mpi_bcast(y1, 1, MPI_REAL8, max_rank, MPI_COMM_WORLD, ierr)
     call mpi_bcast(x2, 1, MPI_REAL8, max_rank, MPI_COMM_WORLD, ierr)
     call mpi_bcast(y2, 1, MPI_REAL8, max_rank, MPI_COMM_WORLD, ierr)

     if (transpos) then
          tmp = x1
          x1 = y1
          y1 = tmp

          tmp = y2
          y2 = x2
          x2 = tmp
     endif

     end subroutine

     subroutine FindMaxInArray(a, ans, Up, Down) ! Процедура поиска максимального подотрезка в массиве
     implicit none

     real(8), intent(in), dimension(:) :: a
     integer(4), intent(out) :: Up, Down
     real(8), intent(out) :: ans
     real(8) cur, sum, min_sum
     integer(4) min_pos, i

     ans = a(1)
     Up = 1
     Down = 1
     sum = 0d0
     min_sum = 0d0
     min_pos = 0

     do i = 1, size(a)

          sum = sum + a(i)
          cur = sum - min_sum

          if (cur .gt. ans) then
               ans = cur
               Up = min_pos + 1
               Down = i
          endif

          if (sum .lt. min_sum) then
               min_sum = sum
               min_pos = i
          endif

     enddo

     end subroutine FindMaxInArray

end module


      SUBROUTINE CH2DET(A,LDA,N,DET,IERR)
      IMPLICIT NONE
*
*  -- user defined driver routine --
*
*
*     .. Scalar Arguments ..
      INTEGER            LDA, N, IERR
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), DET(*)
*     ..
*
*  Purpose
*  =======
*
*  CH2DET computes the determinant of a matrix proceeding from
*  the Cholesky factorization A of this matrix.
*
*
*  Arguments
*  =========
*
*  A        (input) DOUBLE PRECISION array of DIMENSION (N,N).
*           Before entry, the array A must contain in its upper half
*           the Cholesky factor of the matrix A.
*           Unchanged on exit.
*
*  LDA      (input) INTEGER.
*           LDA is the leading dimension of the array A.
*           Unchanged on exit.
*
*  N        (input) INTEGER.
*           N is the order of the matrix A.
*           Unchanged on exit.
*
*  DET      (output) DOUBLE PRECISION vector, DIMENSION (2).
*           The first argument stores the mantissa and the second
*           gives the exponent of the determinant of the upper
*           triangular matrix BS.
*
*  IERR     (output) INTEGER
*           the error indicator from DPOFA.  this will be
*           zero unless the matrix being factorized is
*           not positive definite.
*
*
*  =====================================================================
*
*     ..
*     .. Parameters ..
*     ..
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   TEN
*     ..
*     .. Local Arrays ..
*     ..
*     .. External Functions ..
*     ..
*     .. External Subroutines ..
*     ..
*     .. Intrinsic Functions ..
*     ..
*     .. Executable Statements ..
*
*
      DET(1) = 1.0D0
      DET(2) = 0.0D0
      TEN = 10.0D0
      DO 50 I = 1, N
         DET(1) = A(I,I)*A(I,I)*DET(1)
         IF (DET(1) .EQ. 0.0D0) GO TO 60
 10      IF (DABS(DET(1)) .GE. 1.0D0) GO TO 20
         DET(1) = TEN*DET(1)
         DET(2) = DET(2) - 1.0D0
         GO TO 10
 20      CONTINUE
 30      IF (DABS(DET(1)) .LT. TEN) GO TO 40
         DET(1) = DET(1)/TEN
         DET(2) = DET(2) + 1.0D0
         GO TO 30
 40      CONTINUE
 50   CONTINUE
 60   CONTINUE
      IERR=0
      RETURN
      END


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!  Test entity oriented variable initializations
!

module m
 INTEGER, parameter :: intParam1 = 2
 !INTEGER, parameter :: intParam2 = intParam1+3
 INTEGER, parameter :: intParamArr4(2)= (/3,4/)
 INTEGER, parameter :: intParamArr5(2)= intParamArr4

 INTEGER :: int1
 INTEGER :: intarr1(2)

 type t1
   integer :: i
   integer :: j
   integer :: k
 end type
 type (t1):: t1_inst
 type (t1), parameter :: t1_param1 = t1(1,2,3)
 type (t1), parameter :: t1_param2 = t1_param1
 type (t1), parameter :: t1_param_array(3) = (/t1(1,2,3), t1(2,3,4), t1(3,4,5)/)

 data int1,intarr1,t1_inst / 18, 81, 82, t1(1,2,3) /
end module m

SUBROUTINE module_test(strt_idx, result)
  use m

 INTEGER :: strt_idx
 INTEGER, dimension(:) :: result

 type t2
   integer :: i
   integer :: j
   integer :: k
 end type
 type (t2):: t2_inst = t2(6,7,8)
!
 result(strt_idx) = intParam1
 result(strt_idx+1:strt_idx+2) = intParamArr4
 result(strt_idx+3:strt_idx+4) = intParamArr5
 result(strt_idx+5) = int1
 result(strt_idx+6:strt_idx+7) = intarr1
 result(strt_idx+8) = t1_inst%i
 result(strt_idx+9) = t1_inst%j
 result(strt_idx+10) = t1_inst%k
 result(strt_idx+11) = t2_inst%i
 result(strt_idx+12) = t2_inst%j
 result(strt_idx+13) = t2_inst%k

END SUBROUTINE

PROGRAM wa04
!
 PARAMETER (N=247)

 INTEGER, dimension(N) :: result, expect

 INTERFACE
   SUBROUTINE module_test( strt_idx, result)
     INTEGER :: strt_idx
     INTEGER, dimension(:) :: result
   END SUBROUTINE
 END INTERFACE

 data expect / &
! intParam1
  2, &
! intParam2
  5, &
! int8Param1
  16, &
! intParamArr1
  6,6,6,6,6,6,6,6,6,6, &
! intParamArr2
  3,3,3,3,3,3,3,3,3,3, &
! intParamArr3
  3,4, &
! intParamArr4
  3,4, &
! intParamArr5
  6,8, &
! intParamArr6
  12,12,12,12,12,12,12,12,12,12, &
! intParamArr7
  9,16, &
! intParamArr8
  6,20, &
! intParamArr9
  5,32, &
! int1
  2, &
! int2
  15, &
! int3
  3,4, &
! int4
  33, &
! intArr1
  5,6, &
! intArr2
  6,8, &
! intArr3
  3,5,7,9,11, &
! intArr4
  2,3,7,8,9, &
! intArr5
  6,6,6,6,6, &
! intArr6
  6,8, &
! intArr7
  2,2,2,2,2,2,2,2,2,2, &
! intArr8
  1,2,3,4,5,6,7,8,9,10, &
! intArr9
  20,20,20,20,20,20,20,20,20,20, &
! intArr10
  3,4, &
! intArr11
  -2,-2,-2,-2,-2,-2,-2,-2,-2,-2, &
! intArr12
  51,42,33,24,15, &
! t1_param1
  1,2,3, &
! t1_param2
  1,2,3, &
! t1_param_array
  1,2,3,2,3,4,3,4,5, &
! t1_inst1
  2,2,3, &
! t1_inst2
  1,2,3, &
! t1_array
  1,2,3,2,3,4,3,4,5, &
! t2param1
  4,51,42,33,24,15, &
! t2inst1
  1,1,2,3,4,5, &
! t2inst2
  2,3,4,5,6,7, &
! t2inst3
  2,51,42,33,24,15, &
! t3inst1
  2,4,2,0, &
! t3inst2
  2,1,2,3, &
! t4inst1
  2,4,2,0,8, &
! t4inst2
  2,1,2,3,7, &
! t4inst3
  2,1,2,3,5, &
! t5inst1
  4,2,0,2, &
! t5inst2
  1,2,3,2, &
! t6Param1
  4,51,42,33,24,15,2, &
! t3inst3
  1,1,2,3, &
! t3inst4
  6,1,2,3, &
! t7inst1
  1,2,3, &
! t6inst1
  4,51,42,33,24,15,1, &
! FROM module_test
! module m: intParam1
  2, &
! module m: intParamArr4
  3,4, &
! module m: intParamArr5
  3,4, &
! module m: int1
  18, &
! module m: int2
  81,82, &
! module m: t1_inst
  1,2,3, &
!module m:  t2_inst
  6,7,8, &
!t8_param
  3,4,5,6,7 /

 INTEGER, parameter :: intParam1 = 2
 INTEGER, parameter :: intParam2 = intParam1+3
 INTEGER*8, parameter :: int8Param1 = 16
 INTEGER, parameter :: intParamArr1(10) = 6
 INTEGER, parameter :: intParamArr2(10)= (/(3,i=1,10)/)
 INTEGER, parameter :: intParamArr3(2)= (/3,4/)
 INTEGER, parameter :: intParamArr4(2)= (/3.0,4.0/)
 INTEGER, parameter :: intParamArr5(2)= (/3.0,4.0/)*2
 INTEGER, parameter :: intParamArr6(10)= intParamArr1*2
! constant OP_XTOI/OP_XTOK
 INTEGER, parameter :: intParamArr7(2)= (/3,4/)**2
 INTEGER, parameter :: intParamArr8(2)= (/2.5,4.5/)**2.0
! constant OP_XTOX
 INTEGER, parameter :: intParamArr9(2)= (/2.0,4.0/)**2.5

 INTEGER :: int1 = intParam1
 INTEGER :: int2 = (intParam1+1)*intParam2
 INTEGER :: int3(2)=  intParamArr3

 INTEGER :: intArr1(2)= (/5,6/)
 INTEGER :: intArr2(2) = (/ intParamArr3*2 /)
 INTEGER :: intArr3(5)  = (/ (iii+2,iii=1,10,2) /)
 INTEGER :: intArr4(5)  = (/ intParam1, 3, 7, 8 ,9/)
 INTEGER :: intArr5(5)  = (/ intParamArr1(2:6) /)
 INTEGER :: intArr6(2) = ((/1,2/)+2)*intParam1
 INTEGER :: intArr7(10) = intParam1
 INTEGER :: intArr8(10)= (/(iii,iii=1,10)/)
 INTEGER :: intArr9(10) = 10*intparam1
 INTEGER :: intArr10(2) = (/1,2/)+2
 INTEGER :: intArr11(10) = -intparam1
!
 type t1
    integer :: i
    integer :: j
    integer :: k
 end type
 type (t1), parameter :: t1_param1 = t1(1,2,3)
 type (t1), parameter :: t1_param2 = t1_param1
 type (t1), parameter :: t1_param_array(3) = (/t1(1,2,3), t1(2,3,4), t1(3,4,5)/)

 type (t1) :: t1_inst1 = t1(intParam1,2,3)
 type (t1) :: t1_inst2 = t1_param1;
 type (t1) :: t1_array(3) = t1_param_array
!
 type t2
    integer :: i
    integer :: iary(1:5)
 end type
!
 type (t2), parameter :: t2param1 = t2(4, (/51,42,33,24,15/))
 type (t2) :: t2inst1 = t2(1, (/1,2,3,4,5/))
 type (t2) :: t2inst2 = t2(intParam1, (/(i+2,i=1,5)/) )
 type (t2) :: t2inst3 = t2(intParam1, t2param1%iary )
 INTEGER :: int4 = t2param1%iary(3)
!
 type t3
    integer :: j
    type(t1) :: t1_inst
 end type
!
 type(t3) :: t3inst1 = t3(intParam1, t1(4,2,0) )
 type(t3) :: t3inst2 = t3(intParam1, t1_param1)
 type(t3) :: t3inst3 = t3(t1_param1%i, t1_param1)
 type(t3) :: t3inst4 = t3(intParamArr1(2:2), t1_param1)
!
 type t4
    integer :: j
    type(t1) :: t1_inst
    integer :: k
 end type
!
 type(t4) :: t4inst1 = t4(intParam1, t1(4,2,0), 8)
 type(t4) :: t4inst2 = t4(intParam1, t1_param1, 7)
 type(t4) :: t4inst3 = t4(intParam1, t1_param1, intParam2)
!
 type t5
    type(t1) :: t1_inst
    integer :: j
 end type
!
 type(t5) :: t5inst1 = t5(t1(4,2,0), intParam1)
 type(t5) :: t5inst2 = t5(t1_param1, intParam1)
!
 type t6
    type(t2) :: t2_inst
    integer :: j
 end type
!
 type(t6), parameter :: t6Param1 = t6(t2(4, (/51,42,33,24,15/)) ,2)
 type(t6) :: t6inst1 = t6(t6Param1%t2_inst,1)
 INTEGER :: intArr12(1:5) = t6Param1%t2_inst%iary
!
 type t7
    type(t1) :: t1_inst
 end type
 type(t7) :: t7inst1 = t7(t1_param1)

 type t8
   integer :: t8_intArr(5)
 end type
 type(t8), parameter :: t8_param = t8( (/1,2,3,4,5/) + 2 )

!
 result(1) = intParam1
 result(2) = intParam2
 result(3) = int8Param1
 result(4:13) = intParamArr1
 result(14:23) = intParamArr2
 result(24:25) = intParamArr3
 result(26:27) = intParamArr4
 result(28:29) = intParamArr5
 result(30:39) = intParamArr6
 result(40:41) = intParamArr7
 result(42:43) = intParamArr8
 result(44:45) = intParamArr9
 result(46) = int1
 result(47) = int2
 result(48:49) = int3
 result(50) = int4
 result(51:52) = intArr1
 result(53:54) = intArr2
 result(55:59) = intArr3
 result(60:64) = intArr4
 result(65:69) = intArr5
 result(70:71) = intArr6
 result(72:81) = intArr7
 result(82:91) = intArr8
 result(92:101) = intArr9
 result(102:103) = intArr10
 result(104:113) = intArr11
 result(114:118) = intArr12
 result(119) = t1_param1%i
 result(120) = t1_param1%j
 result(121) = t1_param1%k
 result(122) = t1_param2%i
 result(123) = t1_param2%j
 result(124) = t1_param2%k
 result(125) = t1_param_array(1)%i
 result(126) = t1_param_array(1)%j
 result(127) = t1_param_array(1)%k
 result(128) = t1_param_array(2)%i
 result(129) = t1_param_array(2)%j
 result(130) = t1_param_array(2)%k
 result(131) = t1_param_array(3)%i
 result(132) = t1_param_array(3)%j
 result(133) = t1_param_array(3)%k
 result(134) = t1_inst1%i
 result(135) = t1_inst1%j
 result(136) = t1_inst1%k
 result(137) = t1_inst2%i
 result(138) = t1_inst2%j
 result(139) = t1_inst2%k
 result(140) = t1_array(1)%i
 result(141) = t1_array(1)%j
 result(142) = t1_array(1)%k
 result(143) = t1_array(2)%i
 result(144) = t1_array(2)%j
 result(145) = t1_array(2)%k
 result(146) = t1_array(3)%i
 result(147) = t1_array(3)%j
 result(148) = t1_array(3)%k
 result(149) = t2param1%i
 result(150) = t2param1%iary(1)
 result(151) = t2param1%iary(2)
 result(152) = t2param1%iary(3)
 result(153) = t2param1%iary(4)
 result(154) = t2param1%iary(5)
 result(155) = t2inst1%i
 result(156) = t2inst1%iary(1)
 result(157) = t2inst1%iary(2)
 result(158) = t2inst1%iary(3)
 result(159) = t2inst1%iary(4)
 result(160) = t2inst1%iary(5)
 result(161) = t2inst2%i
 result(162) = t2inst2%iary(1)
 result(163) = t2inst2%iary(2)
 result(164) = t2inst2%iary(3)
 result(165) = t2inst2%iary(4)
 result(166) = t2inst2%iary(5)
 result(167) = t2inst3%i
 result(168) = t2inst3%iary(1)
 result(169) = t2inst3%iary(2)
 result(170) = t2inst3%iary(3)
 result(171) = t2inst3%iary(4)
 result(172) = t2inst3%iary(5)
 result(173) = t3inst1%j
 result(174) = t3inst1%t1_inst%i
 result(175) = t3inst1%t1_inst%j
 result(176) = t3inst1%t1_inst%k
 result(177) = t3inst2%j
 result(178) = t3inst2%t1_inst%i
 result(179) = t3inst2%t1_inst%j
 result(180) = t3inst2%t1_inst%k
 result(181) = t4inst1%j
 result(182) = t4inst1%t1_inst%i
 result(183) = t4inst1%t1_inst%j
 result(184) = t4inst1%t1_inst%k
 result(185) = t4inst1%k
 result(186) = t4inst2%j
 result(187) = t4inst2%t1_inst%i
 result(188) = t4inst2%t1_inst%j
 result(189) = t4inst2%t1_inst%k
 result(190) = t4inst2%k
 result(191) = t4inst3%j
 result(192) = t4inst3%t1_inst%i
 result(193) = t4inst3%t1_inst%j
 result(194) = t4inst3%t1_inst%k
 result(195) = t4inst3%k
 result(196) = t5inst1%t1_inst%i
 result(197) = t5inst1%t1_inst%j
 result(198) = t5inst1%t1_inst%k
 result(199) = t5inst1%j
 result(200) = t5inst2%t1_inst%i
 result(201) = t5inst2%t1_inst%j
 result(202) = t5inst2%t1_inst%k
 result(203) = t5inst2%j
 result(204) = t6Param1%t2_inst%i
 result(205) = t6Param1%t2_inst%iary(1)
 result(206) = t6Param1%t2_inst%iary(2)
 result(207) = t6Param1%t2_inst%iary(3)
 result(208) = t6Param1%t2_inst%iary(4)
 result(209) = t6Param1%t2_inst%iary(5)
 result(210) = t6Param1%j
 result(211) = t3inst3%j
 result(212) = t3inst3%t1_inst%i
 result(213) = t3inst3%t1_inst%j
 result(214) = t3inst3%t1_inst%k
 result(215) = t3inst4%j
 result(216) = t3inst4%t1_inst%i
 result(217) = t3inst4%t1_inst%j
 result(218) = t3inst4%t1_inst%k
 result(219:) = t7inst1%t1_inst%i
 result(220:) = t7inst1%t1_inst%j
 result(221:) = t7inst1%t1_inst%k
 result(222) = t6inst1%t2_inst%i
 result(223) = t6inst1%t2_inst%iary(1)
 result(224) = t6inst1%t2_inst%iary(2)
 result(225) = t6inst1%t2_inst%iary(3)
 result(226) = t6inst1%t2_inst%iary(4)
 result(227) = t6inst1%t2_inst%iary(5)
 result(228) = t6inst1%j

 call module_test(229,result)
 result(243:247) = t8_param%t8_intArr;
!
 call check(result, expect, N);

end program


!>------------------------------------------------------------
!!  Simple unit test to confirm that the fft_shift module works
!!
!!  @author
!!  Ethan Gutmann (gutmann@ucar.edu)
!!
!!------------------------------------------------------------
program test_fftshift
    use fftshifter
    implicit none

    integer,parameter::n=5

    real,dimension(:),allocatable::test1r
    real,dimension(:,:),allocatable::test2r
    complex,dimension(:),allocatable::test1c
    complex,dimension(:,:),allocatable::test2c
    integer::i,j

    allocate(test1r(n))
    allocate(test2r(n,n))
    allocate(test1c(n))
    allocate(test2c(n,n))
    do i=1,n
        test1r(i)=i
        test1c(i)=i
        do j=1,n
            test2r(i,j)=i+j*n*10
            test2c(i,j)=i+j*n*10
        enddo
    enddo
    print*, "1D real array"
    print*, " Original:"
    print*, aint(test1r)
    call fftshift(test1r)
    print*, " Shifted:"
    print*, aint(test1r)
    call ifftshift(test1r)
    print*, " Reverted:"
    print*, aint(test1r)

    print*, "2D real array"
    print*, " Original:"
    print*, aint(test2r)
    call fftshift(test2r)
    print*, " Shifted:"
    print*, aint(test2r)
    call ifftshift(test2r)
    print*, " Reverted:"
    print*, aint(test2r)

    print*, "1D complex array"
    print*, " Original:"
    print*, aint(real(test1c))
    call fftshift(test1c)
    print*, " Shifted:"
    print*, aint(real(test1c))
    call ifftshift(test1c)
    print*, " Reverted:"
    print*, aint(real(test1c))

    print*, "2D complex array"
    print*, " Original:"
    print*, aint(real(test2c))
    call fftshift(test2c)
    print*, " Shifted:"
    print*, aint(real(test2c))
    call ifftshift(test2c)
    print*, " Reverted:"
    print*, aint(real(test2c))

end program test_fftshift


PROGRAM StrangelyAttractive
USE QuadraticMap
Use Draw
IMPLICIT NONE

! Limits for equation coefficients
REAL, PARAMETER :: a_min = -3.
REAL, PARAMETER :: a_max = 3.

! Draw loops?
LOGICAL, PARAMETER :: draw_loops = .FALSE.

! Consider unbound if bigger than this
INTEGER, PARAMETER :: unbound_limit = 1000000
! Iterate that many generations to go to attractor
INTEGER, PARAMETER :: init_iterations = 1000
! Skip that many generations before starting to calculate Lyapunov exponents
INTEGER, PARAMETER :: skip_iterations = 50
! Total number of iterations to calculate
INTEGER, PARAMETER :: total_iterations = 5000000 + init_iterations
! The last iteration to draw
INTEGER, PARAMETER :: last_draw_iteration = 20000
! Check at this step if boring
INTEGER, PARAMETER :: boring_check = 10000
! Consider Lyapunov exponent negative, if smaller than this
REAL, PARAMETER :: l_epsilon = -1E-4
! Start at this point
REAL, PARAMETER :: x0 = 0.1
REAL, PARAMETER :: y0 = 0.1

! Equation coefficients
REAL, DIMENSION(12) :: a
! Current point
REAL x, y
! Calculated points
REAL, DIMENSION(total_iterations) :: points_x
REAL, DIMENSION(total_iterations) :: points_y

! Lyaupunov exponents stuff
! Tangent space basis
REAL, DIMENSION(2) :: e1, e2
! Temprorary variables
REAL :: n1, n2
REAL :: l_acc1, l_acc2
! Fixing factor for logarithm
REAL :: log2 = LOG(2.)
! 'Boring check' total steps
INTEGER, PARAMETER :: check = &
                      boring_check - init_iterations - skip_iterations
! Total steps for Lyapunov exponents calculation
INTEGER, PARAMETER :: l_total = &
                      total_iterations - init_iterations - skip_iterations
! Exponents themselves
REAL :: l_exp1, l_exp2

INTEGER :: i, n
LOGICAL :: again = .TRUE.
LOGICAL :: err = .FALSE.

seed: BLOCK
    INTEGER :: seed_size
    INTEGER, ALLOCATABLE :: seed(:)
    INTEGER :: user_seed
    CALL RANDOM_SEED(size=seed_size)
    ALLOCATE(seed(seed_size))
    WRITE (*, '(A)', ADVANCE='NO') 'Enter random integer seed: '
    READ (*, *) user_seed
    seed = user_seed
    CALL RANDOM_SEED(put=seed)
    DEALLOCATE(seed)
END BLOCK seed

main_loop: DO WHILE (again)
    ! Initialize coefficients
    CALL RANDOM_NUMBER(a)
    a = a_max * a + a_min * (1. - a)

    ! Initialize starting points
    x = x0
    y = y0

    ! Initialize Lyapunov exponents stuff
    l_acc1 = 0
    l_acc2 = 0
    e1 = [1., 0.]
    e2 = [0., 1.]

    err = .FALSE.

    iterations: DO n = 1, total_iterations

        ! Iterate tangent space basis, if needed
        IF (n > init_iterations) THEN
            CALL LINEAR_STEP(a, x, y, e1, e2, n1, n2)
            ! Record exponents if needed
            sum: IF (n > init_iterations + skip_iterations) THEN
                l_acc1 = l_acc1 + LOG(n1)
                l_acc2 = l_acc2 + LOG(n2)
            END IF sum
        END IF

        ! Step to the next point
        CALL QUADRATIC_STEP(a, x, y)
        points_x(n) = x
        points_y(n) = y

        ! Check if unbound
        IF (MAX(ABS(x), ABS(y)) > unbound_limit) THEN
            err = .TRUE.
            EXIT iterations
        END IF

        ! Check if boring
        IF (n == boring_check) THEN
            l_exp1 = l_acc1 / check / log2
            l_exp2 = l_acc2 / check / log2
            boring: IF (MAX(l_exp1, l_exp2) < l_epsilon) THEN
                WRITE (*, '(A)', ADVANCE='NO') 'Current Lyapunov exponents:'
                WRITE (*, '(1X, F5.2, 1X, F5.2)') l_exp1, l_exp2
                WRITE (*, '(A)') 'Boring.'
                err = .TRUE.
                EXIT iterations
            END IF boring
        END IF

    END DO iterations

    IF (err) THEN
        CYCLE main_loop
    END IF

    WRITE (*, '(A)') '*****************************************************'
    WRITE (*, '(A)') 'Parameters used:'
    WRITE (*, '(4X, 6(F6.2))') ( a(i), i=1,6 )
    WRITE (*, '(4X, 6(F6.2))') ( a(i), i=7,12 )
    l_exp1 = l_acc1 / l_total / log2
    l_exp2 = l_acc2 / l_total / log2
    WRITE (*, '(A)', ADVANCE='NO') 'Lyapunov exponents:'
    WRITE (*, '(1X, F5.2, A, 1X, F5.2, A)') l_exp1, ' bits/iteration', &
                                            l_exp2, ' bits/iteration'

    IF (l_exp1 < l_epsilon) THEN
        WRITE(*, '(A)') 'Boring.'
        CYCLE main_loop
    END IF

    loop_or_chaos: IF (ABS(l_exp1) < ABS(l_epsilon)) THEN
        skip_loop: IF (draw_loops) THEN
            WRITE(*, '(A)') 'Loop'
        ELSE
            WRITE(*, '(A)') 'Skipping loop.'
            CYCLE main_loop
        END IF skip_loop
    ELSE
        WRITE(*, '(A)', ADVANCE='NO') 'Chaos. Dimension:'
        full_2d: IF (l_exp2 > 0) THEN
            WRITE(*, '(I1)') 2
        ELSE
            WRITE(*, '(F5.2)') 1. + l_exp1/ABS(l_exp2)
        ENDIF full_2d
    ENDIF loop_or_chaos
    WRITE (*, '(A)') '*****************************************************'

    ! We found it. Go to visualization.
    again = DRAW_POINTS(last_draw_iteration - init_iterations, &
                        points_x(init_iterations+1:), &
                        points_y(init_iterations+1:))

END DO main_loop

END PROGRAM StrangelyAttractive


!*==DAYLEN.spg  processed by SPAG 6.55Dc at 23:48 on  8 Aug 2008
!
!$log: not supported by cvs2svn $
!revision 1.1.1.1  1999/03/12 17:05:31  wagner
!baseline version of weps with bill rust's modifications
!
! revision 1.1.1.1  1995/01/18  04:20:06  wagner
! initial checkin
!
! revision 2.1  1992/03/27  17:22:53  wagner
! version 2 code.
!
!$author: fredfox $
!$date: 2002-09-09 16:09:16 $
!$revision: 1.5 $
!$source: /weru/cvs/weps/weps.src/util/solar/daylen.for,v $

FUNCTION daylen(latitude, daynum, riseangle, degtorad, radtodeg)
!latitude,pdate,civilrise
IMPLICIT NONE
!*--DAYLEN20
!
!*** Start of declarations rewritten by SPAG
!
! Dummy arguments
!
REAL :: latitude,riseangle
INTEGER :: daynum
REAL :: daylen, degtorad, radtodeg
!
! Local variables
!
REAL :: dec,h
REAL :: declination,hourangle
!
!*** End of declarations rewritten by SPAG
!

!     + + + purpose + + +
!     this function calculates the daylength (hours) for any simulation
!     site based on the global position of the site, and day of the
!     year.  the inputs for the function are day of the year, and latitude
!     of the site.

!     + + + keywords + + +
!     day length

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     daylen - the length of the day. Returns the value of this function.
!     daynum - day of year
!     latitude - latitude of the site, degrees (north > 0, south < 0)
!     riseangle - angle of earths rotation where sunrise occurs.
!                 This varies depending on whether you are calculating
!                 direct beam, civil twilight, nautical twilight or
!                 astronomical twilight daylength

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     dec - declination of earth with respect to the sun (degrees)
!     declination -
!     h - hour angle (degrees)
!     hourangle - a function. This variable holds the value returned by
!                 the Hourangle function. Debe assumed this definition

!     + + + common blocks + + +
!     include 'p1unconv.inc'

!     + + + function declarations + + +

!     + + + end specifications + + +

!     declination angle (dec)
dec = declination(daynum, degtorad)

!     sunrise or sunset hour angle
h = hourangle(latitude, dec, riseangle, degtorad, radtodeg)

!     calculate the length of the day
daylen = 2.0*h/15.0

END FUNCTION daylen


!! THis module makes a bimodal distribution using two maxwellians
!! one maxwellian on the left and another on the right and some sort of linear? switching in between...
!! IN 3D in velocity space and 1D in physical space...

!DIMENSIONLESS SEE NOTES FOR THE REDUCTION FORMULAS
module distributions_mod
use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.

implicit none
   interface maxwelveldist
     module procedure maxwelveldist, maxwelveldist_T_vector, maxwelveldist_u_vectors, &
                                     maxwelveldist_T_vector_u_vectors
   end interface

!!!!!!!!!!!!! parameters and global variables
real (DP), parameter, private :: pi25DT = 3.141592653589793238462643d0
!!!!!!!!!!

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! maxwelveldist (T,u_0,n,u) result (y)
!
! This function evauates the 1D maxwellian equilibrium distribution with given temperature and average velocity
! Temperature and average velocity can be arrays (corresponding to different points in x variable
!
! This function evaluates
! f2_{M}(t,x,u)=(2\pi RT(t,x))^{-1/2} \exp(-\frac{(u-\bar{u})^2}{2RT})
!
! This is a reloadable function
!!!!!!!!!!!!!!!!!!!!!!!
!
! this is the copy when T is vector and u is scalar
function maxwelveldist_T_vector_u_vectors (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), dimension (:), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: n    ! density parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: u_0,v_0,w_0  ! average velocity (may depend on x)
   !!! T,n,u_0 must be the same size !!!
   real (DP), dimension (:), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP), dimension (size(T),size(u))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP), dimension (size(T))  :: beta ! local variable  to keep temporary results
   integer (I4B) :: i ! local counter
!!!
beta=sqrt(pi25DT*T)*(pi25DT*T)
do i=1,size(u)
y(:,i) = n*exp(-((u(i)-u_0)*(u(i)-u_0)+(v(i)-v_0)*(v(i)-v_0)+&
                  (w(i)-w_0)*(w(i)-w_0))/max(T,0.0000001_DP))/beta
end do
end function maxwelveldist_T_vector_u_vectors

! this is the copy when T is vector and u is scalar
function maxwelveldist_T_vector (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), dimension (:), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: n    ! density parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: u_0, v_0,w_0  ! average velocity (may depend on x)
   !!! T,n,u_0 must be the same size !!!
   real (DP), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP), dimension (size(T))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP), dimension (size(T))  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist_T_vector

! this is the copy when T is scalar and u is vector
function maxwelveldist_u_vectors (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), intent (in) :: T    ! temperature parameter (scalar)
   real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (scalar)
   real (DP), intent (in) :: n    ! density parameter (scalar)
   real (DP), dimension (:), intent (in) :: u,v,w    ! values of the velocity variable
   real (DP), dimension (size(u))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP)  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist_u_vectors

! this is the copy when both T and u are scalars
function maxwelveldist (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (scalar)
   real (DP), intent (in) :: n    ! density parameter (scalar)
   real (DP), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP)  :: y ! value of the dencity for this values of u and T
!!!
   real (DP)  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist

end module distributions_mod


      SUBROUTINE T2DED(SCR,LSCR)

C                             PROCESS T2D  (TIME TO DEPTH CONVERSION)
C                             ------- ---
C
C  DOCUMENT DATE: 19 November 1990
C
C     T2D TRANSFORMS TIME DOMAIN TRACES TO DEPTH DOMAIN TRACES USING USER
C  DEFINED VELOCITY FUNCTIONS.  THE VELOCITIES MAY BE VARIED TEMPORALLY AND
C  SPATIALLY.  THE VELOCITIES MAY BE AVERAGE VELOCITIES OR INTERVAL VELOCITIES.
c  INTERVAL VELOCITIES ARE CONVERTED TO AVERAGE VELOCITIES.  DEPTH
c  CONVERSION UTILIZES THE FORMULA     D=T/2*V
C  INTERVAL VELOCITY DEPTH CONVERSION UTILIZES THE FORMULA
C  D(N+1)=(T(N+1)-T(N))/2*V(N+1).
C     THE VELOCITY FUNCTION MAY BE VARIED SPATIALLY BETWEEN VELOCITY CONTROL
C  POINTS.  VELOCITY CONTROL POINTS ARE DEFINED AS EITHER SHOT POINT NUMBERS
C  OR RP NUMBERS. EACH PARAMETER LIST HAS A START AND END CONTROL POINT WITH THE
C  PARAMETERS BEING CONSTANT FOR ALL POINTS BETWEEN THE FIRST AND LAST CONTROL
C  POINT OF THE LIST.  E.G.  IF THE FIRST CONTROL POINT=100 AND THE LAST CONTROL
C  POINT=110, THE POINTS 101 TO 109 WILL ALSO HAVE THE SAME PARAMETERS APPLIED.
C                 E.G. FNO 1 VTP 2100 1.1 3100 2.1 END
C                      FNO 3 VTP 2300 1.3 3300 2.3 END
C                      FNO 4 VTP 2200 1.0 2500 1.5 3000 2.0B END
C      RESULTS IN FNO 2 VTP 2200 1.2 3200 2.2
C      THE AVERAGE VELOCITY FUNCTION IS EVALUATED FOR EVERY TIME SAMPLE FOR THE
C  CONTROL POINTS.  TRACES BETWEEN VELOCITY CONTROL POINTS RECEIVE A VELOCITY
C  FUNCTION THAT IS THE LINEAR INTERPOLATION OF THE VELOCITIES OF THE
C  CORRESPONDING TIMES ON THE ADJACENT CONTROL POINTS.
C     THE OUTPUT SAMPLE INTERVAL IS CHANGED BY PROCESS T2D TO 1 MIL (.001 SECOND).
C  THUS, IN ORDER TO PLOT DEPTH DATA, USE PLOT PARAMETERS FOR 1 MIL TIME DATA.
C     SPATIAL VARIATION IS BY SHOT IF THE DATA IS SORTED BY SHOT AND IS
C  VARIED BY RP IF THE DATA IS SORTED BY RP.
c     The output units of T2D are meters.  Whenever the SEGY header
c  uses milliseconds, T2D converts it to meters.  Whenever the SEGY header
c  uses seconds, T2D converts it to kilometers.
C     EACH PARAMETER LIST MUST BE TERMINATED WITH THE WORD END.  THE ENTIRE SET
C  OF T2D PARAMETERS MUST BE TERMINATED BY THE WORD END.
C
C    EXAMPLE:
C       T2D
C            SDEPTH 0 EDEPTH 20000 OSI 10 VTYPE AVE
C           FNO 1 VTP 1500 2.2 2200 4.5 3500 6.7 4500 7.0 END
C           FNO 223 VTP 1500 2.9 2100 4.2 3500 6.6 4500 7.0 END
C           FNO 253 VTP 1500 3.0 2100 4.9 3500 6.5 4500 7.0 END
C       END
C
C  THE PARAMETER DICTIONARY
C  --- --------- ----------
C  FNO    - THE FIRST SHOT (OR RP) TO APPLY THE VELOCITIES TO.  SHOT (RP) NUMBERS
C           MUST INCREASE MONOTONICALLY.
C           PRESET=1
C  LNO    - THE LAST SHOT (RP) NUMBER TO APPLY THE VELOCITIES TO.  LNO MUST BE
C           LARGER THAN FNO IN EACH LIST AND MUST INCREASE LIST TO LIST.
C           DEFAULT=FNO
C  VTYPE  - THE TYPE OF VELOCITY FUNCTION GIVEN IN THE VTP PARAMETER.
C         = AVE,  AVERAGE VELOCITIES.
C         = INT,  INTERVAL VELOCITIES.
C           PRESET = INT.  E.G. VTYPE AVE
C  VTP    - VELOCITY-TIME-PAIRS.  A LIST OF VELOCITY AND TWO-WAY TRAVE TIME
C           (IN SECONDS) PAIRS.  VTP MUST BE GIVEN IN EACH T2D PARAMETER
C           LIST.  A MAXIMUM OF 25 PAIRS MAY BE GIVEN.  DATA TIMES BEFORE
C           THE FIRST GIVEN TIME IN VTP WILL RECEIVE THE FIRST GIVEN VELOCITY.
C           LIKEWISE, DATA TIMES EXCEEDING THE LAST GIVEN TIME IN VTP WILL
C           RECEIVE THE LAST VELOCITY GIVEN IN VTP.
C           DEFAULT=NONE. E.G. VTP 1490 1.0 2000 2.0
C  SDEPTH - THE START DEPTH OF THE OUTPUT DEPTH SECTION.  When this is,
c           the SEGY header is changed so that the deep water delay = SDEPTH
C           PRESET = 0.  E.G. SDEPTH 1000.
C  EDEPTH - THE END DEPTH OF THE OUTPUT DEPTH SECTION.  ALL OUTPUT TRACES WILL
C           HAVE THE SAME END DEPTH.
C           PRESET = 10000.  E.G. EDEPTH 8000
C  OSI    - THE OUTPUT SAMPLE INTERVAL EXPRESSED AS THE DISTANCE BETWEEN SAMPLES.
c           The output sample interval should be similar to time sample
c           intervals.  e.g.  osi 4 gets written in the SEGY as 4 meters
c           whereas in time it would be 4 mils.
C           PRESET = 5. (METERS).  E.G. OSI 10.
C  ADDWB  - WHEN GIVEN A VALUE OF YES, THE WATER BOTTOM TIME IS ADDED TO THE
C           VELOCITY FUNCTION AFTER SPATIAL VARIATION HAS BEEN DONE.
C           PRESET=NO
C  END    - TERMINATES EACH PARAMETER LIST.
C
C
C  WRITTEN AND COPYRIGHTED BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, JULY 1983
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
c  mod 12 oct 89 to convert interval vtps to average vtps.
c  mod 10 mar 90 by pch to to the above on interval velocities ONLY!
c  mod 6 Aug 97 - Add check for OSI > 32 because OSI*1000 must fit in a
c       SEG-Y 16 bit header word.
c  mod 6 Oct 06 - Change sdepth & edepth preset to -1, so each they can change
c                 on every trace like delay and nsamps do
c  mod 6 Oct 06 - Change OSI preset to 1 (like as in 1m, or 1mil)
C
C  ARGUMENTS:
C  SCR    - A SCRATCH ARRAY AT LEAST 60 32BIT WORDS LONG.
C  LSCR   - THE SAME ARRAY BUT USED FOR LONG INTEGERS.  PRIME DOESN'T ALLOW
C           EQUIVALENCING OF ARGUMENTS.
C
C  DISC PARAMETER LIST ORDER:
C  WORD 1)  FNO      (ALL ENTRIES ARE 32 BITS LONG)
C       2   LNO
C       3)  OSI
C       4)  SDEPTH
C       5)  EDEPTH
C       6)  ADDWB
C       7)  LPRINT
C       8)  NVTPS  - THE NUMBER OF ENTRIES IN THE VTP GIVEN BY THE USER
C       9)  ODELAY - THE DELAY OF THE OUTPUT
C       10)  VTYPE
C       11-60) VTP  - ALWAYS 50 LONG
C
C
C
      PARAMETER (NPARS=10)                                              ! /* THE NUMBER OF USER PARAMETERS
      PARAMETER (MAXVTP=50)                                             ! /* THE MAXIMUM NUMBER OF VTPS THAT T2DEX CAN HANDLE
      PARAMETER (NWRDS=MAXVTP+NPARS)                                    ! /* THE NUMBER OF WORDS IN EACH DISK OPARAMETER LIST
      PARAMETER (MULTIV=10)                                             ! /* THE INDEX OF THE FIRST MULTIVALUED PARAMETER
      CHARACTER*6 NAMES(NPARS)
      CHARACTER*1 TYPES(NPARS)
      DIMENSION LENGTH(NPARS)
      CHARACTER*80 TOKEN
      DIMENSION VALS(NPARS),LVALS(NPARS)
      COMMON /EDITS/ IERROR,IWARN,IRUN,NOW,ICOMPT
      COMMON /T2DCOM/ MUNIT,NLISTS
      COMMON /READT/ILUN,NUMHDR,NUMDAT,IUNHDR,IREELM,INTRCS,IFMT,NSKIP,
     *   SECS,LRENUM,ISRCF,IDTYPE
      DIMENSION SCR(111),LSCR(111)
      INTEGER FNO,SDEPTH,EDEPTH,VTYPE
C
C
      EQUIVALENCE (FNO,LVALS(1)),
     2            (LNO,LVALS(2)),
     3            (ADDWB,LVALS(3)),
     4            (LPRINT,LVALS(4)),
     5            (OSI,VALS(5)),
     6            (SDEPTH,LVALS(6)),
     7            (EDEPTH,LVALS(7)),
     9            (VTYPE,LVALS(9)),
     *            (VTP,VALS(10))
      DATA NAMES/'FNO   ',
     2           'LNO   ',
     3           'ADDWB ',
     4           'LPRINT',
     5           'OSI   ',
     6           'SDEPTH',
     7           'EDEPTH',
     8           'ODELAY',
     9           'VTYPE ',
     *           'VTP   '/
      DATA LENGTH/3,3,5,6,3,6,6,6,5,3/
      DATA TYPES/'L','L','A','L','F','L','L','F','A','F'/
      DATA NVTPS/0/, NVTPS1/-1/
C****
C****      SET THE PRESETS
C****
      FNO=1
      LNO=9999999
      VTP=-1.
      OSI=1.                                                            ! /* 5. METERS BETWEEN SAMPLES
      SDEPTH=-1.
      EDEPTH=-1
      VTYPE=2                                                           ! /* 1= INTERVAL, 2= AVERAGE
      LPRINT=0
      IADDWB=0
      LLNO = 0
      NLISTS=0
      NS=0
C****
C****   GET A PARAMETER FILE
C****
      CALL GETFIL(1,MUNIT,TOKEN,ISTAT)
C****
C****   THE CURRENT COMMAND LINE IN THE SYSTEM BUFFER MAY HAVE THE PARAMETERS.
C****   GET A PARAMETER LIST FROM THE USER.
C****
      NTOKES=1
  100 CONTINUE
      CALL GETOKE(TOKEN,NCHARS)                                         ! /* GET A TOKEN FROM THE USER PARAMETER LINE
      CALL UPCASE(TOKEN,NCHARS)                                         ! /* CONVERT THE TOKEN TO UPPERCASE
      IF(NCHARS.GT.0) GO TO 150
      IF(NOW.EQ.1) PRINT 140
  140 FORMAT(' <  ENTER PARAMETERS  >')
      CALL RDLINE                                                       ! /* GET ANOTHER USER PARAMETER LINE
      NTOKES=0
      GO TO 100
  150 CONTINUE
      NTOKES=NTOKES+1
      DO 190 I=1,NPARS                                                  ! /* SEE IF IT IS A PARAMETER NAME
      LEN=LENGTH(I)                                                     ! /* GET THE LEGAL PARAMETER NAME LENGTH
      IPARAM=I                                                          ! /* SAVE THE INDEX
      IF(TOKEN(1:NCHARS).EQ.NAMES(I)(1:LEN).AND.NCHARS.EQ.LEN) GO TO 200
  190 CONTINUE                                                          ! /* STILL LOOKING FOR THE NAME
      IF(TOKEN(1:NCHARS).EQ.'END'.AND.NCHARS.EQ.3) GO TO 1000           ! /* END OF PARAM LIST?
      IF(NS.NE.0) GO TO 230
      PRINT 191, TOKEN(1:NCHARS)
  191 FORMAT(' ***  ERROR  *** T2D DOES NOT HAVE A PARAMETER ',
     *  'NAMED ',A10)
      IERROR=IERROR+1
      GO TO 100
C****
C****    FOUND THE PARAMETER NAME, NOW FIND THE VALUE
C****
  200 CONTINUE
      NS=0
      NPARAM=IPARAM
  210 CONTINUE                                                          ! /*  NOW FIND THE VALUE
      CALL GETOKE(TOKEN,NCHARS)
      CALL UPCASE(TOKEN,NCHARS)
      NTOKES=NTOKES+1
      IF(NCHARS.GT.0) GO TO 230                                         ! /* END OF LINE?
      IF(NOW.EQ.1) PRINT 140                                            ! /* THIS ALLOWS A PARAMETER TO BE ON A DIFFERENT LINE FROM THE NAME
      CALL RDLINE                                                       ! /* GET ANOTHER LINE
      NTOKES=0
      GO TO 210
  230 CONTINUE
      IF(TYPES(NPARAM).NE.'A') GO TO 240
      IF(NAMES(NPARAM).EQ.'ADDWB'.AND.TOKEN(1:NCHARS).EQ.'YES')
     *    IADDWB=1
      IF(NAMES(NPARAM).EQ.'VTYPE'.AND.TOKEN(1:NCHARS).EQ.'AVE') VTYPE=2
      GOTO 100
  240 CONTINUE
      CALL DCODE(TOKEN,NCHARS,AREAL,ISTAT)                              ! /* TRY AND DECODE IT
      IF(ISTAT.EQ.2) GO TO 420                                          ! /* =2 MEANS IT IS A NUMERIC
      IERROR=IERROR+1                                                   ! /* DCODE PRINTED AN ERROR
      GO TO 100
  420 IF(TYPES(NPARAM).EQ.'L') GO TO 500
      IF(NPARAM.LT.MULTIV) GO TO 490                                    ! /*  IS IT A MULTIVALUED PARAMETER
      NS=NS+1                                                           ! /*  THE TOKEN WAS A MULTI-VALUED PARAMETER
      nvtps = ns
      ITEMP=MULTIV
      SCR(NS+ITEMP)=AREAL
      GO TO 100
  490 VALS(NPARAM)=AREAL                                                ! /*  FLOATING POINT VALUES
      GO TO 100
  500 CONTINUE                                                          ! /*  32 BIT INTEGER VALUES
      LVALS(NPARAM)=AREAL
      GO TO 100
C****
C****   FINISHED A LIST, NOW DO THE ERROR AND VALIDITY CHECKS
C****
 1000 CONTINUE                                                          ! /* MAKE SURE ALL SHOT & RP NUMBERS INCREASE
      IF(LNO.EQ.9999999) LNO=FNO                                        ! /* DEFAULT LNO TO FNO
      IF(FNO.GT.LLNO) GO TO 1020                                        ! /*  IS FNO LARGER THAN THE LAST LNO
      PRINT 1010
 1010 FORMAT(' ***  ERROR  ***  SHOT AND RP NUMBERS MUST INCREASE.')
      IERROR=IERROR+1
 1020 IF(LNO.GE.FNO) GO TO 1030                                         ! /* DO THEY INCREASE IN THIS LIST
      PRINT 1010
      IERROR=IERROR+1
 1030 IF( nvtps .EQ. 0 ) THEN
         PRINT *,' ***  ERROR  ***  VTP NOT GIVEN.'
         IERROR=IERROR+1
      ENDIF
c 1070 IF( SDEPTH .GE.-1.) GO TO 1080
c      PRINT 1075
c 1075 FORMAT(' ***  ERROR  ***  SDEPTH MUST BE POSITIVE.')
c      IERROR=IERROR+1
c 1080 IF(EDEPTH.GT.0.) GO TO 1090
c      PRINT 1085
c 1085 FORMAT(' ***  ERROR  ***  EDEPTH IS REQUIRED.')
c      IERROR=IERROR+1
c 1090 IF((EDEPTH-SDEPTH)/OSI.GT.100.) GO TO 1100
c      PRINT 1095
c 1095 FORMAT(' ***  WARNING  ***  UNUSUALLY SHORT OUTPUT REQUESTED.')
c      IWARN=IWARN+1
 1100 CONTINUE
      IF(OSI.GT.0.) GO TO 1110
      PRINT 1105,OSI
 1105 FORMAT(' ***  ERROR  ***  INVALID VALUE OF ',F10.5,' FOR OSI.')
      IERROR=IERROR+1
 1110 CONTINUE
      IF( osi .GT. 32 ) THEN
          PRINT *,' ***  ERROR  ***  OSI must be less than 32.'
          ierror = ierror + 1
      ENDIF
      DO 1200 II=1,NVTPS,2                                              ! /*  CHECK THE VTP FOR ERRORS
      I=II+NPARS
      SCR(I)=SCR(I)/2.                                                  ! /* ****  CONVERT TWO WAY TRAVE TIMES TO ONE WAY!!!!!
      IF(SCR(I).GT.0) GO TO 1160
      PRINT 1150,SCR(I)
 1150 FORMAT(' ***  ERROR  ***  ILLEGAL VTP VELOCITY OF ',F10.4)
      IERROR=IERROR+1
 1160 J=I+1
      IF(SCR(J).GE.0.AND.SCR(J).LT.20.) GO TO 1180
      PRINT 1170,SCR(J)
 1170 FORMAT(' ***  ERROR  ***  ILLEGAL VTP TIME OF ',F10.4)
      IERROR=IERROR+1
 1180 IF(II.EQ.1) GO TO 1200
      IF(SCR(J).GT.SCR(J-2)) GO TO 1200
      PRINT 1190,SCR(J)
 1190 FORMAT(' ***  ERROR  ***  THE VTP TIME OF ',F10.4,' DECREASED.')
      IERROR=IERROR+1
 1200 CONTINUE
      NVTPS1=NVTPS
      LLNO=LNO
C****
C****      WRITE THE PARAMETER LIST TO DISC
C****
      IF(NVTPS.LE.MAXVTP) GO TO 1360
      ITEMP=MAXVTP/2
      PRINT 1350,ITEMP
 1350 FORMAT(' ***  ERROR  ***  T2D CAN HANDLE ONLY ',I3,' VTPS.')
      IERROR=IERROR+1
 1360 CONTINUE
      LSCR(1)=FNO
      LSCR(2)=LNO
      SCR(3)=OSI
      LSCR(4)=SDEPTH
      LSCR(5)=EDEPTH
      LSCR(6)=IADDWB
      LSCR(7)=LPRINT
      LSCR(8)=NVTPS
      LSCR(10)=VTYPE
      ITEMP=NPARS+1
      ITEMP1=NPARS+NVTPS
      IF(IAND(LPRINT,1).EQ.1)  PRINT *,(LSCR(I),I=1,2),
     *   SCR(3),(LSCR(J),J=4,8),LSCR(10),(SCR(J),J=ITEMP,ITEMP1)
      CALL WRDISC(MUNIT,SCR,NWRDS)
      NLISTS=NLISTS+1
      LLNO=LNO
      LNO=9999999                                                       ! /* DEFAULT THE DEFAULTS
      NS=0                                                              ! /* SET THE NUMBER OF MULTI-VALUED PARAMETER ENTRIES BACK TO ZER0
      VTP=-1.
 2020 CALL GETOKE(TOKEN,NCHARS)                                         ! /* GET THE NEXT TOKEN
      CALL UPCASE(TOKEN,NCHARS)
      NTOKES=NTOKES+1
      IF(NCHARS.GT.0) GO TO 2030                                        ! /* WAS IT THE END OF A LINE?
      IF(NOW.EQ.1) PRINT 140
      CALL RDLINE                                                       ! /* GET ANOTHER LINE
      NTOKES=0
      GO TO 2020
 2030 IF(TOKEN(1:NCHARS).NE.'END'.OR.NCHARS.NE.3) GO TO 150
      RETURN                                                            ! /*  FINISHED ALL OF THE PARAMETERS!!!
      END