	subroutine nelmin ( fn, n, start, xmin, ynewlo, reqmin, step,
     &                    konvge, kcount, icount, numres, ifault )

!*****************************************************************************80
!
!! NELMIN minimizes a function using the Nelder-Mead algorithm.
!
!  Discussion:
!
!    This routine seeks the minimum value of a user-specified function.
!
!    Simplex function minimisation procedure due to Nelder and Mead (1965),
!    as implemented by O'Neill(1971, Appl.Statist. 20, 338-45), with
!    subsequent comments by Chambers+Ertel(1974, 23, 250-1), Benyon(1976,
!    25, 97) and Hill(1978, 27, 380-2)
!
!    The function to be minimized must be defined by a function of
!    the form
!
!      function fn ( x )
!      real ( kind = 8 ) fn
!      real ( kind = 8 ) x(*)
!
!    and the name of this subroutine must be declared EXTERNAL in the
!    calling routine and passed as the argument FN.
!
!    This routine does not include a termination test using the
!    fitting of a quadratic surface.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    27 February 2008
!
!  Author:
!
!    Original FORTRAN77 version by R ONeill.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    John Nelder, Roger Mead,
!    A simplex method for function minimization,
!    Computer Journal,
!    Volume 7, 1965, pages 308-313.
!
!    R ONeill,
!    Algorithm AS 47:
!    Function Minimization Using a Simplex Procedure,
!    Applied Statistics,
!    Volume 20, Number 3, 1971, pages 338-345.
!
!  Parameters:
!
!    Input, external FN, the name of the function which evaluates
!    the function to be minimized.
!
!    Input, integer ( kind = 4 ) N, the number of variables.
!    0 < N is required.
!
!    Input/output, real ( kind = 8 ) START(N).  On input, a starting point
!    for the iteration.  On output, this data may have been overwritten.
!
!    Output, real ( kind = 8 ) XMIN(N), the coordinates of the point which
!    is estimated to minimize the function.
!
!    Output, real ( kind = 8 ) YNEWLO, the minimum value of the function.
!
!    Input, real ( kind = 8 ) REQMIN, the terminating limit for the variance
!    of the function values.  0 < REQMIN is required.
!
!    Input, real ( kind = 8 ) STEP(N), determines the size and shape of the
!    initial simplex.  The relative magnitudes of its elements should reflect
!    the units of the variables.
!
!    Input, integer ( kind = 4 ) KONVGE, the convergence check is carried out
!    every KONVGE iterations. 0 < KONVGE is required.
!
!    Input, integer ( kind = 4 ) KCOUNT, the maximum number of function
!    evaluations.
!
!    Output, integer ( kind = 4 ) ICOUNT, the number of function evaluations
!    used.
!
!    Output, integer ( kind = 4 ) NUMRES, the number of restarts.
!
!    Output, integer ( kind = 4 ) IFAULT, error indicator.
!    0, no errors detected.
!    1, REQMIN, N, or KONVGE has an illegal value.
!    2, iteration terminated because KCOUNT was exceeded without convergence.
!
	implicit none

	integer ( kind = 4 ) n

	real ( kind = 8 ), parameter :: ccoeff = 0.5D+00
	real ( kind = 8 ) del
	real ( kind = 8 ), parameter :: ecoeff = 2.0D+00
	real ( kind = 8 ), parameter :: eps = 0.001D+00
	real ( kind = 8 ), external :: fn
	integer ( kind = 4 ) i
	integer ( kind = 4 ) icount
	integer ( kind = 4 ) ifault
	integer ( kind = 4 ) ihi
	integer ( kind = 4 ) ilo
	integer ( kind = 4 ) j
	integer ( kind = 4 ) jcount
	integer ( kind = 4 ) kcount
	integer ( kind = 4 ) konvge
	integer ( kind = 4 ) l
	integer ( kind = 4 ) numres
	real ( kind = 8 ) p(n,n+1)
	real ( kind = 8 ) p2star(n)
	real ( kind = 8 ) pbar(n)
	real ( kind = 8 ) pstar(n)
	real ( kind = 8 ), parameter :: rcoeff = 1.0D+00
	real ( kind = 8 ) reqmin
	real ( kind = 8 ) rq
	real ( kind = 8 ) start(n)
	real ( kind = 8 ) step(n)
	real ( kind = 8 ) x
	real ( kind = 8 ) xmin(n)
	real ( kind = 8 ) y(n+1)
	real ( kind = 8 ) y2star
	real ( kind = 8 ) ylo
	real ( kind = 8 ) ynewlo
	real ( kind = 8 ) ystar
	real ( kind = 8 ) z
!
!  Check the input parameters.
!
	if ( reqmin <= 0.0D+00 ) then
	ifault = 1
	return
	end if

	if ( n < 1 ) then
	ifault = 1
	return
	end if

	if ( konvge < 1 ) then
	ifault = 1
	return
	end if
!
!  Initialization.
!
	icount = 0
	numres = 0
	jcount = konvge
	del = 1.0D+00
	rq = reqmin * real ( n, kind = 8 )
!
!  Initial or restarted loop.
!
	do

	p(1:n,n+1) = start(1:n)
	y(n+1) = fn ( start )
	icount = icount + 1
!
!  Define the initial simplex.
!
	do j = 1, n
      x = start(j)
      start(j) = start(j) + step(j) * del
      p(1:n,j) = start(1:n)
      y(j) = fn ( start )
      icount = icount + 1
      start(j) = x
	end do
!
!  Find highest and lowest Y values.  YNEWLO = Y(IHI) indicates
!  the vertex of the simplex to be replaced.
!
	ilo = minloc ( y(1:n+1), 1 )
	ylo = y(ilo)
!
!  Inner loop.
!
	do while ( icount < kcount )
!
!  YNEWLO is, of course, the HIGHEST value???
!
      ihi = maxloc ( y(1:n+1), 1 )
      ynewlo = y(ihi)
!
!  Calculate PBAR, the centroid of the simplex vertices
!  excepting the vertex with Y value YNEWLO.
!
      do i = 1, n
        pbar(i) = (sum ( p(i,1:n+1) ) - p(i,ihi)) / real(n, kind = 8)
      end do
!
!  Reflection through the centroid.
!
      pstar(1:n) = pbar(1:n) + rcoeff * ( pbar(1:n) - p(1:n,ihi) )
      ystar = fn ( pstar )
      icount = icount + 1
!
!  Successful reflection, so extension.
!
      if ( ystar < ylo ) then

        p2star(1:n) = pbar(1:n) + ecoeff * ( pstar(1:n) - pbar(1:n) )
        y2star = fn ( p2star )
        icount = icount + 1
!
!  Retain extension or contraction.
!
        if ( ystar < y2star ) then
          p(1:n,ihi) = pstar(1:n)
          y(ihi) = ystar
        else
          p(1:n,ihi) = p2star(1:n)
          y(ihi) = y2star
        end if
!
!  No extension.
!
      else

        l = 0
        do i = 1, n + 1
          if ( ystar < y(i) ) then
            l = l + 1
          end if
        end do

        if ( 1 < l ) then

          p(1:n,ihi) = pstar(1:n)
          y(ihi) = ystar
!
!  Contraction on the Y(IHI) side of the centroid.
!
        else if ( l == 0 ) then

          p2star(1:n) = pbar(1:n) + ccoeff * ( p(1:n,ihi) - pbar(1:n) )
          y2star = fn ( p2star )
          icount = icount + 1
!
!  Contract the whole simplex.
!
          if ( y(ihi) < y2star ) then

            do j = 1, n + 1
              p(1:n,j) = ( p(1:n,j) + p(1:n,ilo) ) * 0.5D+00
              xmin(1:n) = p(1:n,j)
              y(j) = fn ( xmin )
              icount = icount + 1
            end do

            ilo = minloc ( y(1:n+1), 1 )
            ylo = y(ilo)

            cycle
!
!  Retain contraction.
!
          else
            p(1:n,ihi) = p2star(1:n)
            y(ihi) = y2star
          end if
!
!  Contraction on the reflection side of the centroid.
!
        else if ( l == 1 ) then

          p2star(1:n) = pbar(1:n) + ccoeff * ( pstar(1:n) - pbar(1:n) )
          y2star = fn ( p2star )
          icount = icount + 1
!
!  Retain reflection?
!
          if ( y2star <= ystar ) then
            p(1:n,ihi) = p2star(1:n)
            y(ihi) = y2star
          else
            p(1:n,ihi) = pstar(1:n)
            y(ihi) = ystar
          end if

        end if

      end if
!
!  Check if YLO improved.
!
      if ( y(ihi) < ylo ) then
        ylo = y(ihi)
        ilo = ihi
      end if

      jcount = jcount - 1

      if ( 0 < jcount ) then
        cycle
      end if
!
!  Check to see if minimum reached.
!
      if ( icount <= kcount ) then

        jcount = konvge

        x = sum ( y(1:n+1) ) / real ( n + 1, kind = 8 )
        z = sum ( ( y(1:n+1) - x )**2 )

        if ( z <= rq ) then
          exit
        end if

      end if

	end do
!
!  Factorial tests to check that YNEWLO is a local minimum.
!
	xmin(1:n) = p(1:n,ilo)
	ynewlo = y(ilo)

	if ( kcount < icount ) then
      ifault = 2
      exit
	end if

	ifault = 0

	do i = 1, n
      del = step(i) * eps
      xmin(i) = xmin(i) + del
      z = fn ( xmin )
      icount = icount + 1
      if ( z < ynewlo ) then
        ifault = 2
        exit
      end if
      xmin(i) = xmin(i) - del - del
      z = fn ( xmin )
      icount = icount + 1
      if ( z < ynewlo ) then
        ifault = 2
        exit
      end if
      xmin(i) = xmin(i) + del
	end do

	if ( ifault == 0 ) then
      exit
	end if
!
!  Restart the procedure.
!
	start(1:n) = xmin(1:n)
	del = eps
	numres = numres + 1

	end do

	return
	end


      SUBROUTINE PMAT(V,W)
C
      PARAMETER(NFAC=49)
      COMMON/OACOF/AA(NFAC,NFAC)
      DIMENSION V(1),W(1),C(NFAC)
C
      DO 10,I=1,NFAC
      DO 20,J=1,NFAC
   20 C(J)=AA(I,J)
C
      W(I)=SDOT(NFAC,C,1,V,1)
   10 CONTINUE
C
C
      RETURN
      END
       FUNCTION SDOT(N,X,INCX,Y,INCY)
       REAL*4 X(1),Y(1),SDOT
       SDOT=0.0
       IX=1
       IY=1
       DO 10 I=1,N
          SDOT=SDOT+X(IX)*Y(IY)
          IX=IX+INCX
          IY=IY+INCY
  10   CONTINUE
       RETURN
       END


      SUBROUTINE CCHKEC( THRESH, TSTERR, NIN, NOUT )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      LOGICAL            TSTERR
      INTEGER            NIN, NOUT
      REAL               THRESH
*     ..
*
*  Purpose
*  =======
*
*  CCHKEC tests eigen- condition estimation routines
*         CTRSYL, CTREXC, CTRSNA, CTRSEN
*
*  In all cases, the routine runs through a fixed set of numerical
*  examples, subjects them to various tests, and compares the test
*  results to a threshold THRESH. In addition, CTRSNA and CTRSEN are
*  tested by reading in precomputed examples from a file (on input unit
*  NIN).  Output is written to output unit NOUT.
*
*  Arguments
*  =========
*
*  THRESH  (input) REAL
*          Threshold for residual tests.  A computed test ratio passes
*          the threshold if it is less than THRESH.
*
*  TSTERR  (input) LOGICAL
*          Flag that indicates whether error exits are to be tested.
*
*  NIN     (input) INTEGER
*          The logical unit number for input.
*
*  NOUT    (input) INTEGER
*          The logical unit number for output.
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            OK
      CHARACTER*3        PATH
      INTEGER            KTREXC, KTRSEN, KTRSNA, KTRSYL, LTREXC, LTRSYL,
     $                   NTESTS, NTREXC, NTRSYL
      REAL               EPS, RTREXC, RTRSYL, SFMIN
*     ..
*     .. Local Arrays ..
      INTEGER            LTRSEN( 3 ), LTRSNA( 3 ), NTRSEN( 3 ),
     $                   NTRSNA( 3 )
      REAL               RTRSEN( 3 ), RTRSNA( 3 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           CERREC, CGET35, CGET36, CGET37, CGET38
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. Executable Statements ..
*
      PATH( 1: 1 ) = 'Complex precision'
      PATH( 2: 3 ) = 'EC'
      EPS = SLAMCH( 'P' )
      SFMIN = SLAMCH( 'S' )
      WRITE( NOUT, FMT = 9994 )
      WRITE( NOUT, FMT = 9993 )EPS, SFMIN
      WRITE( NOUT, FMT = 9992 )THRESH
*
*     Test error exits if TSTERR is .TRUE.
*
      IF( TSTERR )
     $   CALL CERREC( PATH, NOUT )
*
      OK = .TRUE.
      CALL CGET35( RTRSYL, LTRSYL, NTRSYL, KTRSYL, NIN )
      IF( RTRSYL.GT.THRESH ) THEN
         OK = .FALSE.
         WRITE( NOUT, FMT = 9999 )RTRSYL, LTRSYL, NTRSYL, KTRSYL
      END IF
*
      CALL CGET36( RTREXC, LTREXC, NTREXC, KTREXC, NIN )
      IF( RTREXC.GT.THRESH .OR. NTREXC.GT.0 ) THEN
         OK = .FALSE.
         WRITE( NOUT, FMT = 9998 )RTREXC, LTREXC, NTREXC, KTREXC
      END IF
*
      CALL CGET37( RTRSNA, LTRSNA, NTRSNA, KTRSNA, NIN )
      IF( RTRSNA( 1 ).GT.THRESH .OR. RTRSNA( 2 ).GT.THRESH .OR.
     $    NTRSNA( 1 ).NE.0 .OR. NTRSNA( 2 ).NE.0 .OR. NTRSNA( 3 ).NE.0 )
     $     THEN
         OK = .FALSE.
         WRITE( NOUT, FMT = 9997 )RTRSNA, LTRSNA, NTRSNA, KTRSNA
      END IF
*
      CALL CGET38( RTRSEN, LTRSEN, NTRSEN, KTRSEN, NIN )
      IF( RTRSEN( 1 ).GT.THRESH .OR. RTRSEN( 2 ).GT.THRESH .OR.
     $    NTRSEN( 1 ).NE.0 .OR. NTRSEN( 2 ).NE.0 .OR. NTRSEN( 3 ).NE.0 )
     $     THEN
         OK = .FALSE.
         WRITE( NOUT, FMT = 9996 )RTRSEN, LTRSEN, NTRSEN, KTRSEN
      END IF
*
      NTESTS = KTRSYL + KTREXC + KTRSNA + KTRSEN
      IF( OK )
     $   WRITE( NOUT, FMT = 9995 )PATH, NTESTS
*
 9999 FORMAT( ' Error in CTRSYL: RMAX =', E12.3, / ' LMAX = ', I8,
     $      ' NINFO=', I8, ' KNT=', I8 )
 9998 FORMAT( ' Error in CTREXC: RMAX =', E12.3, / ' LMAX = ', I8,
     $      ' NINFO=', I8, ' KNT=', I8 )
 9997 FORMAT( ' Error in CTRSNA: RMAX =', 3E12.3, / ' LMAX = ',
     $      3I8, ' NINFO=', 3I8, ' KNT=', I8 )
 9996 FORMAT( ' Error in CTRSEN: RMAX =', 3E12.3, / ' LMAX = ',
     $      3I8, ' NINFO=', 3I8, ' KNT=', I8 )
 9995 FORMAT( / 1X, 'All tests for ', A3,
     $      ' routines passed the threshold (', I6, ' tests run)' )
 9994 FORMAT( ' Tests of the Nonsymmetric eigenproblem condition',
     $      ' estimation routines', / ' CTRSYL, CTREXC, CTRSNA, CTRSEN',
     $      / )
 9993 FORMAT( ' Relative machine precision (EPS) = ', E16.6,
     $      / ' Safe minimum (SFMIN)             = ', E16.6, / )
 9992 FORMAT( ' Routines pass computational tests if test ratio is ',
     $      'less than', F8.2, / / )
      RETURN
*
*     End of CCHKEC
*
      END


! assignment statement in main program
      PROGRAM TEST1
      ARG1=ARG2+0.5
      WRITE(*,*) ARG1,ARG2
      END


      FUNCTION GLOG (ARG)
C
      REAL*8 GLOG,DLOG,ARG
C
C     BASE E (NATURAL) LOGARITHM
C
      GLOG = DLOG (ARG)
      RETURN
      END


module externalfield

use, intrinsic :: iso_fortran_env

implicit none

! Fortran 2008
integer, parameter, private :: sp = REAL32
integer, parameter, private :: dp = REAL64
integer, parameter, private :: qp = REAL128

contains

      subroutine getexternalfield(x,y,z,t,e0,b0,ierr)
      implicit none
      real*8 :: x,y,z,t
      real*8, dimension(3) :: e0,b0
      integer :: ierr
      real*8 :: bval,dz1bval,dz2bval,dz3bval,dz4bval
      integer :: n
      integer, parameter :: ndipoles=4
      real*8, parameter :: thet0=0.349065850398866  !20 degrees
      real*8, parameter :: drouter=1.4d0*cos(thet0)
      real*8, parameter :: drmiddle=2.563d0
!     real*8, parameter :: effarclen=0.20d0*0.979815536051016d0
!     real*8, parameter :: dd=effarclen*sin(thet0)/thet0 ! dipole z-length
      real*8, parameter :: dd=0.3d0 ! dipole z-length
      real*8, parameter :: effarclen=dd*thet0/sin(thet0)
      real*8, parameter :: z0=0.0d0   !drift space before first dipole
      real*8, parameter :: gam0=120    !1.d0+60.d6/0.510998910d6   !NOTE WELL: fix later to get energy from probcons.f90
      real*8, parameter :: gb0=sqrt((gam0+1.d0)*(gam0-1.d0))
      real*8, parameter :: brho=gb0/299792458.d0*0.510998910d6
      real*8, parameter :: bchic=thet0*abs(brho)/effarclen
      real*8, parameter, dimension(ndipoles) :: z1=(/z0,      dd+drouter+z0, 2*dd+drmiddle+drouter+z0, 3*dd+drmiddle+2*drouter+z0/) !magnet leading edge
      real*8, parameter, dimension(ndipoles) :: z2=(/dd+z0, 2*dd+drouter+z0, 3*dd+drmiddle+drouter+z0, 4*dd+drmiddle+2*drouter+z0/) !magnet trailing edge
!     real*8, parameter, dimension(ndipoles) :: b00=(/-bchic,bchic,bchic,-bchic/)  !chicane magnet B field
      real*8, parameter, dimension(ndipoles) :: b00=(/+bchic,-bchic,-bchic,+bchic/)  !chicane magnet B field
!     real*8, parameter :: eps2=0.100d0/(2.d0*asin(1.d0)) !chicane magnet fringe field parameter
      real*8, parameter :: eps2=0.025  !0.060d0/(2.d0*asin(1.d0)) !chicane magnet fringe field parameter

      e0(1:3)=0.d0
      b0(1:3)=0.d0

!     call getquadbfield(x,y,z,b0)
!     call getsextbfield(x,y,z,b0)

      bval=0.d0
      dz1bval=0.d0
      dz2bval=0.d0
      dz3bval=0.d0
      dz4bval=0.d0
      do n=1,ndipoles
        bval=bval+b00(n)*frntanh(z-z1(n),eps2)-b00(n)*frntanh(z-z2(n),eps2)
        dz1bval=dz1bval+b00(n)*dz1frntanh(z-z1(n),eps2)-b00(n)*dz1frntanh(z-z2(n),eps2)
        dz2bval=dz2bval+b00(n)*dz2frntanh(z-z1(n),eps2)-b00(n)*dz2frntanh(z-z2(n),eps2)
        dz3bval=dz3bval+b00(n)*dz3frntanh(z-z1(n),eps2)-b00(n)*dz3frntanh(z-z2(n),eps2)
        dz4bval=dz4bval+b00(n)*dz4frntanh(z-z1(n),eps2)-b00(n)*dz4frntanh(z-z2(n),eps2)
      enddo
!hardwired for no x-dependence:
      b0(2)=b0(2) + bval   -0.5d0*y**2*dz2bval+y**4/24.d0*dz4bval
      b0(3)=b0(3) + y*dz1bval   -y**3/6.d0*dz3bval
      ierr=0
      return
      end

      subroutine undulatorgetexternalfield(x,y,z,t,e0,b0,ierr)
      implicit none
      real*8 :: x,y,z,t
      real*8, dimension(3) :: e0,b0
      integer :: ierr
      real*8 :: sig,ccon,g0,hinv
      real*8, parameter :: pi=2.d0*asin(1.d0)
      e0(1:3)=0.d0
      b0(1:3)=0.d0

!     sig= 1.0d-2
!     ccon=1.d0/(sqrt(2.d0*pi)*sig)
      hinv=1.d0/2.5d-2 !inverse of half-width of nearly square pulse
! 4.0 and 1.d-2 are pretty good
! 7.0 and 9.d-2 are better
        g0= 4.60d-0*exp(-0.5d0*(hinv*(z+0.20d0))**20) &
     &    + 4.60d-0*exp(-0.5d0*(hinv*(z+0.20d0-1.d0*2.56d0))**20) &
     &     +4.60d-0*exp(-0.5d0*(hinv*(z+0.20d0-2.d0*2.56d0))**20) &
     &    + 4.60d-0*exp(-0.5d0*(hinv*(z+0.20d0-3.d0*2.56d0))**20) &
     &     +4.60d-0*exp(-0.5d0*(hinv*(z+0.20d0-4.d0*2.56d0))**20) &
     &    + 4.60d-0*exp(-0.5d0*(hinv*(z+0.20d0-5.d0*2.56d0))**20) &
     &     +4.60d-0*exp(-0.5d0*(hinv*(z+0.20d0-6.d0*2.56d0))**20)
        if(abs(g0).lt.1.d-18)g0=0.d0 !not necessary but prevents a gnuplot plotting artifact
        b0(1)=g0*y
        b0(2)=g0*x

      call getundulatorfield(x,y,z,t,e0,b0,0.d0,ierr)
      call getundulatorfield(x,y,z,t,e0,b0,2.56d0,ierr)
      call getundulatorfield(x,y,z,t,e0,b0,5.12d0,ierr)
      call getundulatorfield(x,y,z,t,e0,b0,7.68d0,ierr)
      call getundulatorfield(x,y,z,t,e0,b0,10.24d0,ierr)
      call getundulatorfield(x,y,z,t,e0,b0,12.80d0,ierr)
      return
      end

      subroutine getundulatorfield(x,y,z,t,e0,b0,zstart,ierr)
      implicit none
      real*8 :: x,y,z,t,zstart
      real*8, dimension(3) :: e0,b0
      integer :: ierr
!     real*8, parameter :: bfielddip=0.3352642711907601d0 !B field for 100 MeV ss dipole case with rho=1m
      real*8, parameter :: pi=2.d0*asin(1.d0)
      real*8 :: bval,dz1bval,dz2bval,dz3bval,dz4bval
      real*8 :: eps,byplus,byminus,zshft,z1,z2,z3,z4
      integer :: n
      real*8 :: frntanh1,dz1frntanh1,dz2frntanh1,dz3frntanh1,dz4frntanh1
      real*8 :: frntanh2,dz1frntanh2,dz2frntanh2,dz3frntanh2,dz4frntanh2
      real*8 :: frntanh3,dz1frntanh3,dz2frntanh3,dz3frntanh3,dz4frntanh3
      real*8 :: frntanh4,dz1frntanh4,dz2frntanh4,dz3frntanh4,dz4frntanh4
      real*8, parameter :: twopi=4.d0*asin(1.d0)
      real*8, parameter :: bcon=0.7918d0
      real*8, parameter :: lambda_u=2.8d-2
      real*8, parameter :: n_u=77.d0
!     real*8, parameter :: k_u=twopi/lambda_u
!     real*8, parameter :: zmax= (n_u/2.d0-0.25d0)*lambda_u
!     real*8, parameter :: zmax= (n_u/2.d0-0.00d0)*lambda_u
!     real*8, parameter :: zmax= (n_u/2.d0-0.001d0)*lambda_u
!     real*8, parameter :: zmin=-zmax
! IN THIS VERSION E0 AND B0 ARE ADDED TO
!     e0(1:3)=0.d0
!     b0(1:3)=0.d0
!dipole hack HACK:
!x    if(t.ne.-12345678.)then
!x      b0(2)=0.3352642711907601d0 ! 0.33526427T gives rho=1m for 100MeV electron
!x      ierr=0
!x      return
!x    endif
!
!     b0(2)=bfielddip
!     if(z.ge.zmin.and.z.le.zmax)then
!       b0(2)=bcon*cos(k_u*z)
!     endif
      byplus=bcon*1.00d0
      byminus=-bcon*1.00d0
      bval=0.d0; dz1bval=0.d0; dz2bval=0.d0; dz3bval=0.d0; dz4bval=0.d0
      n=1
      eps=1.5d-2/pi ! 4.d-3/pi
      zshft=(n-1)*lambda_u + zstart
      z1=zshft+0.125*lambda_u; z2=zshft+0.375*lambda_u; z3=zshft+0.625*lambda_u; z4=zshft+0.875*lambda_u
      z1=z1+0.125*lambda_u
      call frntanh01234(z-z1,eps,frntanh1,dz1frntanh1,dz2frntanh1,dz3frntanh1,dz4frntanh1)
      call frntanh01234(z-z2,eps,frntanh2,dz1frntanh2,dz2frntanh2,dz3frntanh2,dz4frntanh2)
      call frntanh01234(z-z3,eps,frntanh3,dz1frntanh3,dz2frntanh3,dz3frntanh3,dz4frntanh3)
      call frntanh01234(z-z4,eps,frntanh4,dz1frntanh4,dz2frntanh4,dz3frntanh4,dz4frntanh4)
      bval=bval+byplus*frntanh1-byplus*frntanh2+byminus*frntanh3-byminus*frntanh4
      dz1bval=dz1bval+byplus*dz1frntanh1-byplus*dz1frntanh2+byminus*dz1frntanh3-byminus*dz1frntanh4
      dz2bval=dz2bval+byplus*dz2frntanh1-byplus*dz2frntanh2+byminus*dz2frntanh3-byminus*dz2frntanh4
      dz3bval=dz3bval+byplus*dz3frntanh1-byplus*dz3frntanh2+byminus*dz3frntanh3-byminus*dz3frntanh4
      dz4bval=dz4bval+byplus*dz4frntanh1-byplus*dz4frntanh2+byminus*dz4frntanh3-byminus*dz4frntanh4

!!!   eps=4.d-3/pi
!!!!!!do n=2,n_u-1
      do n=2,nint(n_u)-1
        zshft=(n-1)*lambda_u + zstart
        z1=zshft+0.125*lambda_u; z2=zshft+0.375*lambda_u; z3=zshft+0.625*lambda_u; z4=zshft+0.875*lambda_u
        call frntanh01234(z-z1,eps,frntanh1,dz1frntanh1,dz2frntanh1,dz3frntanh1,dz4frntanh1)
        call frntanh01234(z-z2,eps,frntanh2,dz1frntanh2,dz2frntanh2,dz3frntanh2,dz4frntanh2)
        call frntanh01234(z-z3,eps,frntanh3,dz1frntanh3,dz2frntanh3,dz3frntanh3,dz4frntanh3)
        call frntanh01234(z-z4,eps,frntanh4,dz1frntanh4,dz2frntanh4,dz3frntanh4,dz4frntanh4)
        bval=bval+byplus*frntanh1-byplus*frntanh2+byminus*frntanh3-byminus*frntanh4
        dz1bval=dz1bval+byplus*dz1frntanh1-byplus*dz1frntanh2+byminus*dz1frntanh3-byminus*dz1frntanh4
        dz2bval=dz2bval+byplus*dz2frntanh1-byplus*dz2frntanh2+byminus*dz2frntanh3-byminus*dz2frntanh4
        dz3bval=dz3bval+byplus*dz3frntanh1-byplus*dz3frntanh2+byminus*dz3frntanh3-byminus*dz3frntanh4
        dz4bval=dz4bval+byplus*dz4frntanh1-byplus*dz4frntanh2+byminus*dz4frntanh3-byminus*dz4frntanh4
      enddo

!!!   eps=4.d-3/pi
      n=n_u
      zshft=(n-1)*lambda_u + zstart
      z1=zshft+0.125*lambda_u; z2=zshft+0.375*lambda_u; z3=zshft+0.625*lambda_u; z4=zshft+0.875*lambda_u
      z2=z2-0.125*lambda_u
      call frntanh01234(z-z1,eps,frntanh1,dz1frntanh1,dz2frntanh1,dz3frntanh1,dz4frntanh1)
      call frntanh01234(z-z2,eps,frntanh2,dz1frntanh2,dz2frntanh2,dz3frntanh2,dz4frntanh2)
      bval=bval+byplus*frntanh1-byplus*frntanh2!+byminus*frntanh(z-z3,eps)-byminus*frntanh(z-z4,eps)
      dz1bval=dz1bval+byplus*dz1frntanh1-byplus*dz1frntanh2!+byminus*dz1frntanh(z-z3,eps)-byminus*dz1frntanh(z-z4,eps)
      dz2bval=dz2bval+byplus*dz2frntanh1-byplus*dz2frntanh2!+byminus*dz2frntanh(z-z3,eps)-byminus*dz2frntanh(z-z4,eps)
      dz3bval=dz3bval+byplus*dz3frntanh1-byplus*dz3frntanh2!+byminus*dz3frntanh(z-z3,eps)-byminus*dz3frntanh(z-z4,eps)
      dz4bval=dz4bval+byplus*dz4frntanh1-byplus*dz4frntanh2!+byminus*dz4frntanh(z-z3,eps)-byminus*dz4frntanh(z-z4,eps)
!hardwired for no x-dependence:
      b0(2)=b0(2) + bval  -0.5d0*y**2*dz2bval+y**4/24.d0*dz4bval ! add to the value that b0 had on entry to routine
      b0(3)=b0(3)         + y*dz1bval-y**3/6.d0*dz3bval
      ierr=0
      return
      end

      subroutine oldgetexternalfield(x,y,z,t,e0,b0,ierr)
      implicit none
      real*8 :: x,y,z,t
      real*8, dimension(3) :: e0,b0
      integer :: ierr
!     real*8, parameter :: bfielddip=0.3352642711907601d0 !B field for 100 MeV ss dipole case with rho=1m
      real*8, parameter :: pi=2.d0*asin(1.d0)
      real*8 :: bval,dz1bval,dz2bval,dz3bval,dz4bval
      real*8 :: eps,byplus,byminus,zshft,z1,z2,z3,z4
      integer :: n
      real*8, parameter :: twopi=4.d0*asin(1.d0)
      real*8, parameter :: bcon=0.1d0          ! 0.1 Tesla
      real*8, parameter :: lambda_u=0.01d0     ! 1 cm
      real*8, parameter :: k_u=twopi/lambda_u
      real*8, parameter :: n_u=16.d0
!     real*8, parameter :: zmax= (n_u/2.d0-0.25d0)*lambda_u
!     real*8, parameter :: zmax= (n_u/2.d0-0.00d0)*lambda_u
      real*8, parameter :: zmax= (n_u/2.d0-0.001d0)*lambda_u
      real*8, parameter :: zmin=-zmax
      e0(1:3)=0.d0
      b0(1:3)=0.d0
!     b0(2)=bfielddip
!     if(z.ge.zmin.and.z.le.zmax)then
!       b0(2)=bcon*cos(k_u*z)
!     endif
      byplus=0.1d0*1.35d0
      byminus=-0.1d0*1.35d0
      bval=0.d0; dz1bval=0.d0; dz2bval=0.d0; dz3bval=0.d0; dz4bval=0.d0
      n=1
      eps=4.d-3/pi
      zshft=(n-1)*1.d-2
      z1=zshft+0.125d-2; z2=zshft+0.375d-2; z3=zshft+0.625d-2; z4=zshft+0.875d-2
      z1=z1+0.125d-2
      bval=bval+byplus*frntanh(z-z1,eps)-byplus*frntanh(z-z2,eps)+byminus*frntanh(z-z3,eps)-byminus*frntanh(z-z4,eps)
 dz1bval=dz1bval+byplus*dz1frntanh(z-z1,eps)-byplus*dz1frntanh(z-z2,eps)+byminus*dz1frntanh(z-z3,eps)-byminus*dz1frntanh(z-z4,eps)
 dz2bval=dz2bval+byplus*dz2frntanh(z-z1,eps)-byplus*dz2frntanh(z-z2,eps)+byminus*dz2frntanh(z-z3,eps)-byminus*dz2frntanh(z-z4,eps)
 dz3bval=dz3bval+byplus*dz3frntanh(z-z1,eps)-byplus*dz3frntanh(z-z2,eps)+byminus*dz3frntanh(z-z3,eps)-byminus*dz3frntanh(z-z4,eps)
 dz4bval=dz4bval+byplus*dz4frntanh(z-z1,eps)-byplus*dz4frntanh(z-z2,eps)+byminus*dz4frntanh(z-z3,eps)-byminus*dz4frntanh(z-z4,eps)

      eps=4.d-3/pi
!!!!!!do n=2,n_u-1
      do n=2,nint(n_u)-1
        zshft=(n-1)*1.d-2
        z1=zshft+0.125d-2; z2=zshft+0.375d-2; z3=zshft+0.625d-2; z4=zshft+0.875d-2
        bval=bval+byplus*frntanh(z-z1,eps)-byplus*frntanh(z-z2,eps)+byminus*frntanh(z-z3,eps)-byminus*frntanh(z-z4,eps)
   dz1bval=dz1bval+byplus*dz1frntanh(z-z1,eps)-byplus*dz1frntanh(z-z2,eps)+byminus*dz1frntanh(z-z3,eps)-byminus*dz1frntanh(z-z4,eps)
   dz2bval=dz2bval+byplus*dz2frntanh(z-z1,eps)-byplus*dz2frntanh(z-z2,eps)+byminus*dz2frntanh(z-z3,eps)-byminus*dz2frntanh(z-z4,eps)
   dz3bval=dz3bval+byplus*dz3frntanh(z-z1,eps)-byplus*dz3frntanh(z-z2,eps)+byminus*dz3frntanh(z-z3,eps)-byminus*dz3frntanh(z-z4,eps)
   dz4bval=dz4bval+byplus*dz4frntanh(z-z1,eps)-byplus*dz4frntanh(z-z2,eps)+byminus*dz4frntanh(z-z3,eps)-byminus*dz4frntanh(z-z4,eps)
      enddo

      eps=4.d-3/pi
      n=n_u
      zshft=(n-1)*1.d-2
      z1=zshft+0.125d-2; z2=zshft+0.375d-2; z3=zshft+0.625d-2; z4=zshft+0.875d-2
      z2=z2-0.125d-2
      bval=bval+byplus*frntanh(z-z1,eps)-byplus*frntanh(z-z2,eps)!+byminus*frntanh(z-z3,eps)-byminus*frntanh(z-z4,eps)
 dz1bval=dz1bval+byplus*dz1frntanh(z-z1,eps)-byplus*dz1frntanh(z-z2,eps)!+byminus*dz1frntanh(z-z3,eps)-byminus*dz1frntanh(z-z4,eps)
 dz2bval=dz2bval+byplus*dz2frntanh(z-z1,eps)-byplus*dz2frntanh(z-z2,eps)!+byminus*dz2frntanh(z-z3,eps)-byminus*dz2frntanh(z-z4,eps)
 dz3bval=dz3bval+byplus*dz3frntanh(z-z1,eps)-byplus*dz3frntanh(z-z2,eps)!+byminus*dz3frntanh(z-z3,eps)-byminus*dz3frntanh(z-z4,eps)
 dz4bval=dz4bval+byplus*dz4frntanh(z-z1,eps)-byplus*dz4frntanh(z-z2,eps)!+byminus*dz4frntanh(z-z3,eps)-byminus*dz4frntanh(z-z4,eps)
!hardwired for no x-dependence:
      b0(2)=bval-0.5d0*y**2*dz2bval+y**4/24.d0*dz4bval
      b0(3)=y*dz1bval-y**3/6.d0*dz3bval
      ierr=0
      return
      end

      subroutine stupakovgetexternalfield(x,y,z,t,e0,b0,ierr)
      implicit none
      real*8 :: x,y,z,t
      real*8, dimension(3) :: e0,b0
      integer :: ierr
      real*8 :: bval,dz1bval,dz2bval,dz3bval,dz4bval
      integer :: n
      integer, parameter :: ndipoles=4
      real*8, parameter :: thet0=2.14d0*2.d0*asin(1.d0)/180.d0
      real*8, parameter :: drouter=1.0d0*cos(thet0)
      real*8, parameter :: drmiddle=0.20d0
!!!!! real*8, parameter :: dd=0.20d0 ! dipole z-length
!!!!! real*8, parameter :: z0=0.10d0  !drift space before first dipole
!!!!! real*8, parameter :: bchic=0.74766244446414987d0
      real*8, parameter :: dd=10.d0  !   0.50d0  !0.50 is for Stupakov/Emma test    !!!!dd=0.20d0 ! dipole z-length
      real*8, parameter :: z0=0.d0 ! 0.10d0   !drift space before first dipole
!     real*8, parameter :: bchic=0.33469850546399954d0  !334... for Stupakov/Emma  !!!   0.74766244446414987d0
      real*8, parameter :: bchic=0.33526427119076008d0
      real*8, parameter, dimension(ndipoles) :: z1=(/z0,      dd+drouter+z0, 2*dd+drmiddle+drouter+z0, 3*dd+drmiddle+2*drouter+z0/) !magnet leading edge
      real*8, parameter, dimension(ndipoles) :: z2=(/dd+z0, 2*dd+drouter+z0, 3*dd+drmiddle+drouter+z0, 4*dd+drmiddle+2*drouter+z0/) !magnet trailing edge
      real*8, parameter, dimension(ndipoles) :: b00=(/+bchic,-bchic,-bchic,+bchic/)  !chicane magnet B field
!!!!!!real*8, parameter :: eps2=0.075d0/(2.d0*asin(1.d0)) !chicane magnet fringe field parameter
      real*8, parameter :: eps2=10.d0*0.0075d0/(2.d0*asin(1.d0)) !chicane magnet fringe field parameter
!hack-------
!     if(x.ne.-1234567.d0)then
!     e0(1:3)=0.d0
!     b0(1:3)=0.d0
!     b0(2)=0.33526427119076008d0   !0.335264T corresponds to rho=1m for 100MeV electron
!     b0(2)=0.33469850546399954d0   !corresponds to rho=1.5m for 150MeV electron
!     ierr=0
!     return
!     endif
!-----------
      e0(1:3)=0.d0
      b0(1:3)=0.d0
      bval=0.d0
      dz1bval=0.d0
      dz2bval=0.d0
      dz3bval=0.d0
      dz4bval=0.d0
      do n=1,ndipoles
        bval=bval+b00(n)*frntanh(z-z1(n),eps2)-b00(n)*frntanh(z-z2(n),eps2)
        dz1bval=dz1bval+b00(n)*dz1frntanh(z-z1(n),eps2)-b00(n)*dz1frntanh(z-z2(n),eps2)
        dz2bval=dz2bval+b00(n)*dz2frntanh(z-z1(n),eps2)-b00(n)*dz2frntanh(z-z2(n),eps2)
        dz3bval=dz3bval+b00(n)*dz3frntanh(z-z1(n),eps2)-b00(n)*dz3frntanh(z-z2(n),eps2)
        dz4bval=dz4bval+b00(n)*dz4frntanh(z-z1(n),eps2)-b00(n)*dz4frntanh(z-z2(n),eps2)
      enddo
!hardwired for no x-dependence:
      b0(2)=bval
!     b0(2)=bval-0.5d0*y**2*dz2bval+y**4/24.d0*dz4bval
!     b0(3)=y*dz1bval-y**3/6.d0*dz3bval
      ierr=0
      return
      end

      subroutine dipolegetexternalfield(x,y,z,t,e0,b0,ierr)
      implicit none
      real*8 :: x,y,z,t
      real*8, dimension(3) :: e0,b0
      integer :: ierr
      real*8, parameter :: bfielddip=0.74766244446414987d0
      e0(1:3)=0.d0
      b0(1:3)=0.d0
      b0(2)=bfielddip
      ierr=0
      return
      end

      real*8 function frntanh(y,eps)
      implicit none
      real*8 :: y,eps
      frntanh = tanh(y/eps)/2.d0 +.5d0
      return
      end

!
      real*8 function dz1frntanh(y,eps)
      implicit none
      real*8 :: y,eps
      if (abs(y/eps).lt.32.d0) then
        dz1frntanh = 2*Exp(2*y/eps)/(eps*(1 + Exp(2*y/eps))**2)
      else
        dz1frntanh = 0.d0
      endif
      return
      end
!
      real*8 function dz2frntanh(y,eps)
      implicit none
      real*8 :: y,eps
      if (abs(y/eps).lt.32.d0) then
        dz2frntanh = (-4*Exp((2*y)/eps)*                       &
     &  (-1 + Exp((2*y)/eps)))/((1 + Exp((2*y)/eps))**3*eps**2)
      else
        dz2frntanh = 0.d0
      endif
      return
      end
!
      real*8 function dz3frntanh(y,eps)
      implicit none
      real*8 :: y,eps
      if (abs(y/eps).lt.32.d0) then
        dz3frntanh = 8*Exp(2*y/eps)*                           &
     &      (1 - 4*Exp(2*y/eps) + Exp(4*y/eps))/               &
     &   (eps**3*(1 + Exp(2*y/eps))**4)
      else
        dz3frntanh = 0.0d0
      endif
      return
      end
!
      real*8 function dz4frntanh(y,eps)
      implicit none
      real*8 :: y,eps
      if (abs(y/eps).lt.32.d0) then
        dz4frntanh =                                                    &
     &(-16*Exp((2*y)/eps)*(-1 + 11*Exp((2*y)/eps) - 11*Exp((4*y)/eps) + &
     &      Exp((6*y)/eps)))/((1 + Exp((2*y)/eps))**5*eps**4)
      else
        dz4frntanh = 0.d0
      endif
      return
      end

      subroutine frntanh01234(y,eps,frntanh,dz1frntanh,dz2frntanh,dz3frntanh,dz4frntanh)
      implicit none
      real*8 :: y,eps,frntanh,dz1frntanh,dz2frntanh,dz3frntanh,dz4frntanh
      real*8 :: exp2yeps,exp4yeps,exp6yeps

      frntanh = tanh(y/eps)/2.d0 +.5d0

      if(abs(y/eps).ge.32.d0)then
        dz1frntanh = 0.d0
        dz2frntanh = 0.d0
        dz3frntanh = 0.d0
        dz4frntanh = 0.d0
        return
      endif

      exp2yeps=Exp(2.d0*y/eps)
!     exp4yeps=Exp(4.d0*y/eps)
!     exp6yeps=Exp(6.d0*y/eps)
      exp4yeps=exp2yeps**2
      exp6yeps=exp2yeps*exp4yeps

        dz1frntanh = 2*exp2yeps/(eps*(1 + exp2yeps)**2)

        dz2frntanh = (-4*exp2yeps*                                      &
     &  (-1 + exp2yeps))/((1 + exp2yeps)**3*eps**2)

        dz3frntanh = 8*exp2yeps*                                        &
     &      (1 - 4*exp2yeps + exp4yeps)/                                &
     &   (eps**3*(1 + exp2yeps)**4)

        dz4frntanh =                                                    &
     &(-16*exp2yeps*(-1 + 11*exp2yeps - 11*exp4yeps +                   &
     &      exp6yeps))/((1 + exp2yeps)**5*eps**4)

      return
      end

      subroutine getquadbfield(xin,yin,zin,barg)
      implicit none
      real*8 :: xin,yin,zin
      real*8, dimension(3) :: barg,b,bp
      integer, parameter :: nquads=9
      real*8, parameter :: pi180=2.d0*asin(1.d0)/180.d0
      real*8, parameter, dimension(nquads) :: xcent=(/-1.1125774E-01,-1.9599797E-01,-3.2267838E-01,-4.3716955E-01,-4.3716955E-01,-4.3716955E-01,-3.2267838E-01,-1.9599797E-01,-1.1125774E-01/)
      real*8, parameter, dimension(nquads) :: xlen=(/0.49,0.49,0.49,0.49,0.49,0.49,0.49,0.49,0.49/)
      real*8, parameter, dimension(nquads) :: epsx=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02/)
      real*8, parameter, dimension(nquads) :: zcent=(/5.4562402E+00,9.2071771E+00,1.4814551E+01,2.1615190E+01,2.2788973E+01,2.3962756E+01,3.0763395E+01,3.6370769E+01,4.0121706E+01/)
      real*8, parameter, dimension(nquads) :: zlen=(/0.714238,0.714238,1.0,0.714238,0.714238,0.714238,1.0,0.714238,0.714238/)
      real*8, parameter, dimension(nquads) :: epsz=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02/)
      real*8, parameter, dimension(nquads) :: tilt=(/+0.022587909d0,+0.022587909d0,+0.022587909d0,0.d0,0.d0,0.d0,-0.022587909d0,-0.022587909d0,-0.022587909d0/)
      real*8, parameter, dimension(nquads) :: bcon=(/0.733338004,-0.485812703,0.284195941,0.396952876,-0.968972588,0.396952876,0.284195941,-0.485812703,0.733338004/) !these are k1 values

      real*8, parameter :: gam0=1.d0+10.d9/0.510998910d6   !NOTE WELL: fix later to get energy from probcons.f90
      real*8, parameter :: gb0=sqrt((gam0+1.d0)*(gam0-1.d0))
      real*8, parameter :: brho=gb0/299792458.d0*0.510998910d6

      real*8 :: x1,x2,z1,z2,ang,x,y,z,xp,yp,zp,b0,bval,dz1bval,dz2bval
!!!   real*8 :: dz3bval,dz4bval
      integer :: n
!     real*8, external :: bump,dz1bump,dz2bump,dz3bump,dz4bump
      b(1:3)=0.d0
      do n=1,nquads
!shift:
        x=xin-xcent(n)
        y=yin
        z=zin-zcent(n)
!rotate:
        ang=tilt(n) !-tilt(n) to try with minus sign
        xp=x*cos(ang)+z*sin(ang)
        yp=y
        zp=-x*sin(ang)+z*cos(ang)
!compute:
        b0=bcon(n)*brho ! multiply by brho to convert k1 values to B field gradient in T/m
        x1=-0.5d0*xlen(n); x2=0.5d0*xlen(n)
        z1=-0.5d0*zlen(n); z2=0.5d0*zlen(n)
        bval=b0*bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
        dz1bval=b0*dz1bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
        dz2bval=b0*dz2bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
!!!     dz3bval=b0*dz3bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
!!!     dz4bval=b0*dz4bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
        bp(1)=bval*yp  -dz2bval*(yp**3+3.d0*xp**2*yp)/12.d0
        bp(2)=bval*xp  -dz2bval*(xp**3+3.d0*yp**2*xp)/12.d0
        bp(3)=0.d0     +dz1bval*xp*yp
!rotate the field back to one aligned with the original frame:
        b(1)=b(1)+(bp(1)*cos(-ang)+bp(3)*sin(-ang))
        b(2)=b(2)+bp(2)
        b(3)=b(3)+(-bp(1)*sin(-ang)+bp(3)*cos(-ang))
      enddo
      barg(1:3)=barg(1:3)+b(1:3)
      return
      end

      subroutine getsextbfield(xin,yin,zin,barg)
      implicit none
      real*8 :: xin,yin,zin
      real*8, dimension(3) :: barg,b,bp
      integer, parameter :: nsexts=4
      real*8, parameter :: pi180=2.d0*asin(1.d0)/180.d0
      real*8, parameter :: gam0=1.d0+10.d9/0.510998910d6   !NOTE WELL: fix later to get energy from probcons.f90
      real*8, parameter :: gb0=sqrt((gam0+1.d0)*(gam0-1.d0))
      real*8, parameter :: brho=gb0/299792458.d0*0.510998910d6
      real*8, parameter, dimension(nsexts) :: xcent=(/-8.9019667E-02,-1.7483542E-01,-1.7483542E-01,-8.9019667E-02/)
      real*8, parameter, dimension(nsexts) :: xlen=(/0.49,0.49,0.49,0.49/)
      real*8, parameter, dimension(nsexts) :: epsx=(/0.02,0.02,0.02,0.02/)
      real*8, parameter, dimension(nsexts) :: zcent=(/4.4718954E+00,8.2704391E+00,3.7307507E+01,4.1106051E+01/)
      real*8, parameter, dimension(nsexts) :: zlen=(/0.762d0,0.250d0,0.250d0,0.762d0/)
      real*8, parameter, dimension(nsexts) :: epsz=(/0.02,0.02,0.02,0.02/)
      real*8, parameter, dimension(nsexts) :: tilt=(/+0.022587909d0,+0.022587909d0,-0.022587909d0,-0.022587909d0/)
!!!   real*8, parameter, dimension(nsexts) :: bcon=(/28.3284704,-0.636171592,-0.636171592,28.3284704/) !these are K2 values
!     real*8, parameter, dimension(nsexts) :: bcon=(/1416.1737483450d0/brho*2.d0,-0.636171592d0,-0.636171592d0,1416.1737483450d0/brho*2.d0/) !these are K2 values
      real*8, parameter, dimension(nsexts) :: bcon=(/42.6987867d0,-8.03335029d0,-8.03335029d0,42.6987867d0/) !these are K2 values

      real*8 :: x1,x2,z1,z2,ang,x,y,z,xp,yp,zp,b0,bval,dz1bval,dz2bval
!!!   real*8 :: dz3bval,dz4bval
      integer :: n
!     real*8, external :: bump,dz1bump,dz2bump,dz3bump,dz4bump
      b(1:3)=0.d0
      do n=1,nsexts
!shift:
        x=xin-xcent(n)
        y=yin
        z=zin-zcent(n)
!rotate:
        ang=tilt(n) !-tilt(n) to try with minus sign
        xp=x*cos(ang)+z*sin(ang)
        yp=y
        zp=-x*sin(ang)+z*cos(ang)
!compute:
        b0=bcon(n)*brho/2.d0
        x1=-0.5d0*xlen(n); x2=0.5d0*xlen(n)
        z1=-0.5d0*zlen(n); z2=0.5d0*zlen(n)
        bval=b0*bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
        dz1bval=b0*dz1bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
        dz2bval=b0*dz2bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
!!!     dz3bval=b0*dz3bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
!!!     dz4bval=b0*dz4bump(zp,z1,z2,epsz(n)) !*bump(xp,x1,x2,epsx(n))
        bp(1)=2.d0*bval*xp*yp
        bp(2)=bval*(xp**2-yp**2)
        bp(3)=0.d0
!rotate the field back to one aligned with the original frame:
        b(1)=b(1)+(bp(1)*cos(-ang)+bp(3)*sin(-ang))
        b(2)=b(2)+bp(2)
        b(3)=b(3)+(-bp(1)*sin(-ang)+bp(3)*cos(-ang))
      enddo
      barg(1:3)=barg(1:3)+b(1:3)
      return
      end
!
      real*8 function bump(s,s1,s2,eps)
      implicit none
      real*8 :: s,s1,s2,eps
!     real*8, external :: frntanh
      bump=(frntanh(s-s1,eps)-frntanh(s-s2,eps))
      return
      end
!
      real*8 function dz1bump(s,s1,s2,eps)
      implicit none
      real*8 :: s,s1,s2,eps
!     real*8, external :: dz1frntanh
      dz1bump=(dz1frntanh(s-s1,eps)-dz1frntanh(s-s2,eps))
      return
      end
!
      real*8 function dz2bump(s,s1,s2,eps)
      implicit none
      real*8 :: s,s1,s2,eps
!     real*8, external :: dz2frntanh
      dz2bump=(dz2frntanh(s-s1,eps)-dz2frntanh(s-s2,eps))
      return
      end
!
      real*8 function dz3bump(s,s1,s2,eps)
      implicit none
      real*8 :: s,s1,s2,eps
!     real*8, external :: dz3frntanh
      dz3bump=(dz3frntanh(s-s1,eps)-dz3frntanh(s-s2,eps))
      return
      end
!
      real*8 function dz4bump(s,s1,s2,eps)
      implicit none
      real*8 :: s,s1,s2,eps
!     real*8, external :: dz4frntanh
      dz4bump=(dz4frntanh(s-s1,eps)-dz4frntanh(s-s2,eps))
      return
      end

end module


      subroutine getggHWWamps(p,Mloop_bquark,Mloop_tquark)
c--- Returns a series of arrays representing the dressed amp[itudes
c--- for the process gg->Higgs->ZZ; there are:
c---        Mloop_bquark(h1,h2,h34,h56)   top quark mass=mt
c---        Mloop_tquark(h1,h2,h34,h56)   bottom quark mass=mb
c---
c--- The overall factor on the amplitude is:
c---
c---      (2d0*gwsq*gsq/(16d0*pisq)*gwsq/2d0)**2 * delta(a,b)
c---
      include 'constants.f'
      include 'ewcouple.f'
      include 'qcdcouple.f'
      include 'masses.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      include 'anom_higgs.f'
      double precision p(mxpart,4),msq(fn:nf,fn:nf),msqgg,fac
      double precision mfsq,tau,tauinv,rt,rescale
      double complex Mloop_tquark(2,2),Mloop_bquark(2,2),
     & fachiggs,amphiggs,f,e3De4,higgsprop,props

      call spinoru(6,p,za,zb)

      fachiggs=higgsprop(s(1,2))

c--- fill amplitudes with contributions of Higgs: top loop
      mfsq=mt**2
      tau=s(1,2)/(4d0*mfsq)
      tauinv=1d0/tau

      if (tau .le. 1d0) then
         f=dcmplx(dasin(sqrt(tau))**2)
      elseif (tau .gt. 1d0) then
         rt=sqrt(1d0-tauinv)
         f=-0.25d0*(dcmplx(log((1d0+rt)/(1d0-rt)))-im*pi)**2
      else
         f=czip
      endif
      e3De4=2d0*za(3,5)*zb(6,4)/(s(3,4)*s(5,6))
      amphiggs=mfsq*(cone+(cone-dcmplx(tauinv))*f)*im*e3De4
      Mloop_tquark(1,1)=fachiggs*amphiggs*za(1,2)/zb(2,1)
      Mloop_tquark(1,2)=czip
      Mloop_tquark(2,1)=czip
      Mloop_tquark(2,2)=fachiggs*amphiggs*zb(1,2)/za(2,1)

c--- fill amplitudes with contributions of Higgs: bottom loop
      mfsq=mb**2
      tau=s(1,2)/(4d0*mfsq)
      tauinv=1d0/tau

      if (tau .le. 1d0) then
         f=dcmplx(dasin(sqrt(tau))**2)
      elseif (tau .gt. 1d0) then
         rt=sqrt(1d0-tauinv)
         f=-0.25d0*(dcmplx(log((1d0+rt)/(1d0-rt)))-im*pi)**2
      else
         f=czip
      endif
      amphiggs=mfsq*(cone+(cone-dcmplx(tauinv))*f)*im*e3De4

      Mloop_bquark(1,1)=fachiggs*amphiggs*za(1,2)/zb(2,1)
      Mloop_bquark(1,2)=czip
      Mloop_bquark(2,1)=czip
      Mloop_bquark(2,2)=fachiggs*amphiggs*zb(1,2)/za(2,1)

c--- Rescale for width study
      if((keep_smhiggs_norm).and.(anom_higgs)) then
         rescale=chi_higgs**2
         Mloop_tquark(:,:)=Mloop_tquark(:,:)*rescale
         Mloop_bquark(:,:)=Mloop_bquark(:,:)*rescale
      endif

      props=
     &  s(3,4)/dcmplx(s(3,4)-wmass**2,wmass*wwidth)
     & *s(5,6)/dcmplx(s(5,6)-wmass**2,wmass*wwidth)
c      props=cone ! debug phase
      Mloop_bquark(:,:)=Mloop_bquark(:,:)*props
      Mloop_tquark(:,:)=Mloop_tquark(:,:)*props

      return
      end


!dis
!dis    Open Source License/Disclaimer, Forecast Systems Laboratory
!dis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
!dis
!dis    This software is distributed under the Open Source Definition,
!dis    which may be found at http://www.opensource.org/osd.html.
!dis
!dis    In particular, redistribution and use in source and binary forms,
!dis    with or without modification, are permitted provided that the
!dis    following conditions are met:
!dis
!dis    - Redistributions of source code must retain this notice, this
!dis    list of conditions and the following disclaimer.
!dis
!dis    - Redistributions in binary form must provide access to this
!dis    notice, this list of conditions and the following disclaimer, and
!dis    the underlying source code.
!dis
!dis    - All modifications to this software must be clearly documented,
!dis    and are solely the responsibility of the agent making the
!dis    modifications.
!dis
!dis    - If significant modifications or enhancements are made to this
!dis    software, the FSL Software Policy Manager
!dis    (softwaremgr@fsl.noaa.gov) should be notified.
!dis
!dis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
!dis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
!dis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
!dis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
!dis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
!dis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
!dis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
!dis
!dis

  SUBROUTINE the2t(thetae,p,tparcel)

    ! Calculates temperature at any pressure level along a saturation
    ! adiabat by iteratively solving eq 2.76 from Wallace and Hobbs (1977).

    ! Adpated from USAF routine, B. Shaw, NOAA/FSL

    USE constants
    IMPLICIT NONE

    INTEGER                          :: iter
    REAL, EXTERNAL                   :: mixsat
    REAL, INTENT(IN)                 :: p
    REAL                             :: tcheck
    REAL                             :: theta
    REAL, INTENT(IN)                 :: thetae
    REAL                             :: tovtheta
    REAL, INTENT(OUT)                :: tparcel
    LOGICAL                          :: converged

    converged = .false.
    tovtheta = (p / 1000.0) ** kappa
    tparcel = thetae / exp(lv * 0.012 / (cp *295.0)) *tovtheta

    iterloop: DO iter = 1 , 50

      theta = thetae / exp(lv*mixsat(tparcel,p*100.)/(cp*tparcel))
      tcheck = theta * tovtheta

      IF (ABS(tparcel - tcheck) .lt. 0.05) THEN
        converged = .true.
        EXIT iterloop
      ENDIF
      tparcel = tparcel + (tcheck - tparcel) * 0.3

    ENDDO iterloop
    IF (.NOT.converged) THEN
      PRINT *, 'WARNING!! THETAE to TEMP calc did not converge!'
      print *, 'thetae and p:',thetae,p
    ENDIF

    RETURN
  END SUBROUTINE the2t


!> Author:   Jabir Ali Ouassou
!> Category: Programs
!>
!> This program calculates the current-voltage relation of a one-dimensional superconducting structure.

program voltage_p
  use :: structure_m
  use :: stdio_m
  use :: math_m

  !--------------------------------------------------------------------------------!
  !                                GLOBAL VARIABLES                                !
  !--------------------------------------------------------------------------------!

  ! Declare the superconducting structure
  type(structure)                     :: stack
  type(conductor), target             :: na, nb

  ! Declare program control parameters
  real(wp), parameter                 :: threshold   = 1e-2
  real(wp), parameter                 :: tolerance   = 1e-5
  integer,  parameter                 :: iterations  = 100

  ! Declare variables used by the program
  real(wp), dimension(:), allocatable :: voltage
  real(wp), dimension(:), allocatable :: current
  integer                             :: n

  !--------------------------------------------------------------------------------!
  !                           INITIALIZATION PROCEDURE                             !
  !--------------------------------------------------------------------------------!

  ! Redefine stdout and stderr
  stdout = output('output.log')
  stderr = output('error.log')

  ! Construct the central material stack
  stack = structure()

  ! Ensure that the voltage has an effect
  call stack % cmap('nonequilibrium','T')

  ! Construct the surrounding conductors
  call na % construct()
  call nb % construct()

  ! Disable the conductors from updates
  call na % conf('order','0')
  call nb % conf('order','0')

  ! Thermalize the surrounding conductors
  na % temperature = stack % a % temperature
  nb % temperature = stack % b % temperature

  ! Reinitialize the conductor states
  call na % initialize
  call nb % initialize

  ! Connect the conductors to the stack
  stack % a % material_a => na
  stack % b % material_b => nb

  ! Initialize the voltage and current
  allocate(voltage(iterations), current(iterations))
  call linspace(voltage, 1e-6_wp, 2.00_wp)

  ! Start with a non-selfconsistent bootstrap procedure
  call stack % converge(threshold = threshold, bootstrap = .true.)

  !--------------------------------------------------------------------------------!
  !                           LINEAR SEARCH PROCEDURE                              !
  !--------------------------------------------------------------------------------!

  ! Calculate the charge current as a function of voltage difference
  current = 0
  do n=1,size(voltage)
    ! Update the voltage
    na % voltage = +voltage(n)
    nb % voltage = -voltage(n)

    ! Reset the states
    call na % initialize
    call nb % initialize

    ! Update the state
    call stack % converge(threshold = tolerance, prehook = prehook, posthook = posthook)

    ! Save the charge current to array
    current(n) = stack % a % supercurrent(0,1) + stack % a % lossycurrent(0,1)

    ! Write out the results
    call finalize
  end do

  !--------------------------------------------------------------------------------!
  !                                 SUBROUTINES                                    !
  !--------------------------------------------------------------------------------!

contains
  impure subroutine prehook
    ! Write out status information.
    call status_body('Voltage difference', voltage(n))
  end subroutine

  impure subroutine posthook
    ! Write results to output files.
    character(len=5) :: filename
    write(filename,'(f5.3)') voltage(n)
  end subroutine

  impure subroutine finalize
    ! Write the current-voltage relation to file
    call dump('current.dat', [voltage, current], ['Voltage           ', 'Charge current    '])
  end subroutine
end program


! { dg-do compile }
  double precision, parameter :: x = huge(1d0)
  print*, sum((/x,-x/))
  print*, sum((/x,x,-x,-x/))  ! { dg-error "overflow" }
  print*, sum((/x,-x,1d0/))
  print*, sum((/1d0,x,-x/))
end


Program testkind

! int8, int16, int32, int64
!    Parámetros de tipo Kind para especificar un tipo "INTEGER" con un tamaño de
! almacenamiento de 8, 16, 32 y 64 bits. Es negativo si una plataforma de
! destino no es compatible con el tipo particular. (Fortran 2008 o posterior).

! real32, real64, real128
!    Parámetros de tipo Kind para especificar un tipo "REAL" con un tamaño de
! almacenamiento de 32, 64 y 128 bits. Es negativo si una plataforma de
! destino no es compatible con el tipo particular. (Fortran 2008 o posterior).

use ISO_FORTRAN_ENV

implicit none

integer(kind = int8), parameter :: is = int8, id = int16, il = int32, ix = int64
integer(kind = int8), parameter :: rs = real32, rd = real64, rl = real128
! s : Short, d : Double, l : Large, x : eXtralarge

integer(kind = is) :: el_entero
integer(is) :: otro_entero
real(kind = rl) :: los_reales
real(rl) :: otros_reales
complex(kind = rl) :: el_complejado
complex(rl) :: otro_complejado

el_entero = 8
los_reales = 10.00_rl
otros_reales = 355.00_rl / 113.00_rl ! Almost pi
el_complejado = (355.00_rl, 113.00_rl)
otro_complejado = (3.00_rl, 4.00_rl)

write(*,*) el_entero, los_reales
write(*,*) otro_entero, otros_reales
write(*,*) el_complejado, otro_complejado
write(*,*) real(el_complejado)/imag(el_complejado), abs(otro_complejado)

write(*,*) is, id, il, ix
write(*,*) rs, rd, rl

end program testkind


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM HSL_MA48_big_example
   USE HSL_MA48_DOUBLE
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )
   INTEGER :: i, j, l, info, m, n, ne, ns, rank, dependent
   TYPE ( ZD01_TYPE ) :: MATRIX, SUBMATRIX
   TYPE ( MA48_CONTROL ) :: CONTROL
   TYPE ( MA48_AINFO ) :: AINFO
   TYPE ( MA48_FINFO ) :: FINFO
   TYPE ( MA48_SINFO ) :: SINFO
   TYPE ( MA48_FACTORS ) :: FACTORS
   INTEGER, ALLOCATABLE, DIMENSION( : ) :: ROWS, COLS, ROWS_order, COLS_order
   REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: B, X

!  Read matrix order and number of entries

   READ( 5, * ) n, ne
   m = n
   MATRIX%m = m ; MATRIX%n = n ; MATRIX%ne = ne

!  Allocate arrays of appropriate sizes

   ALLOCATE( MATRIX%VAL( ne ),  MATRIX%ROW( ne ),  MATRIX%COL( ne ) )
   ALLOCATE( B( m ), X( n ), ROWS( m ), COLS( n ) )

!  Read matrix

   READ( 5, * ) ( MATRIX%ROW( i ), MATRIX%COL( i ), MATRIX%VAL( i ), i = 1, ne )

!  Construct right-hand side B for solution of ones

   B = 0.0_wp
   DO i = 1, ne
     B(MATRIX%row(i)) = B(MATRIX%row(i)) + MATRIX%VAL(i)
   END DO

!  Initialize the structures

   CALL MA48_initialize( FACTORS, CONTROL )
   CONTROL%btf = n + 1

!  Analyse and factorize

   CALL MA48_analyse( MATRIX, FACTORS, CONTROL, AINFO, FINFO )
   IF ( AINFO%flag < 0 ) THEN
     WRITE( 6, '( A, I0 )' )                                                   &
       ' Failure of MA48_ANALYSE with AINFO%flag = ',  AINFO%flag
     STOP
   END IF
   WRITE( 6, "( ' dimension, rank ', I0, 1X, I0 )" ) n, AINFO%rank
!  STOP

!  Write row and column reorderings

   CALL MA48_special_rows_and_cols( FACTORS, rank, COLS, ROWS, info )
!  WRITE( 6, "( A, /, ( 10I5 ) )" ) ' row orderings:', ROWS( : rank )
!  WRITE( 6, "( A, /, ( 10I5 ) )" ) ' column orderings:', COLS( : rank )
!  WRITE( 28, "( A, /, ( 10I5 ) )" ) ' row orderings:', ROWS( : rank )
!  WRITE( 28, "( A, /, ( 10I5 ) )" ) ' column orderings:', COLS( : rank )

   WRITE( 6, "( ' dimension, rank ', I0, 1X, I0 )" ) n, rank

   CALL MA48_solve( MATRIX, FACTORS, B, X, CONTROL, SINFO )
   IF ( SINFO%flag == 0 ) WRITE( 6, '( A, /,( 6ES11.3 ) )' )                    &
     ' Solution of set of equations without refinement is', X( : 5 )

!  Flag the rows and columns that make up the nonsingular submatrix

   ALLOCATE( ROWS_order( m ), COLS_order( n ) )
   COLS_order = 0
   DO i = 1, rank
    COLS_order( COLS( i ) ) = i
   END DO
   ROWS_order = 0
   DO i = 1, rank
     ROWS_order( ROWS( i ) ) = i
   END DO

        l = 0
        dependent = m + 1
        DO i = 1, rank
          IF ( ROWS_order( i ) > 0 ) THEN
            l = l + 1
            ROWS_order( i ) = l
            ROWS( l ) = i
          ELSE
            dependent = dependent - 1
            ROWS_order( i ) = dependent
            ROWS( dependent ) = i
          END IF
        END DO

   ns = 0
   DO l = 1, ne
     i = ROWS_order( MATRIX%col( l ) )
     j = COLS_order( MATRIX%row( l ) )
     IF ( i <= rank .AND. j > 0 ) THEN
       ns = ns + 1
       MATRIX%row( ns ) = i
       MATRIX%col( ns ) = j
       MATRIX%val( ns ) = MATRIX%val( l )
     END IF
   END DO
   MATRIX%ne = ns

   B = 0.0_wp
   DO i = 1, ne
     B(MATRIX%row(i)) = B(MATRIX%row(i)) + MATRIX%VAL(i)
   END DO

!  WRITE( 28, "( 3( 2I4, ES12.4 ) ) " ) ( MATRIX%row( i ),               &
!     MATRIX%col( i ), MATRIX%val( i ), i = 1, MATRIX%ne )

   MATRIX%m = rank ; MATRIX%n = rank ; MATRIX%ne = ns
   WRITE( 6, "( ' dimension, nnz submatrix ', I0, 1X, I0 )" ) rank, ns

   CONTROL%btf = MATRIX%n
   CONTROL%u = 2.5_wp
   CALL MA48_analyse( MATRIX, FACTORS, CONTROL, AINFO, FINFO )
        write(6,*) CONTROL
        write(6,*) AINFO
        write(6,*) FINFO
   WRITE( 6, "( ' dimension, rank ', I0, 1X, I0 )" ) n, AINFO%rank

   WRITE( 6, "( ' nnz(prec,factors)', 2( 1X, I0 ))") &
      MATRIX%ne, FINFO%size_factor

   CALL MA48_solve( MATRIX, FACTORS, B, X, CONTROL, SINFO )
!  IF ( SINFO%flag == 0 ) WRITE( 6, '( A, /,( 6ES11.3 ) )' )                    &
   WRITE( 6, '( A, /,( 6ES11.3 ) )' )                    &
     ' Solution of set of equations without refinement is', X( : 5 )

!  Clean up

   DEALLOCATE( MATRIX%VAL, MATRIX%ROW, MATRIX%COL )
   CALL MA48_FINALIZE( FACTORS, CONTROL, INFO )

   END PROGRAM HSL_MA48_big_example


! FILE : Vector.f90
! AUTHOR: Tyler H. Chang
! LAST UPDATE: June, 2019
! ISO FORTRAN 2003 STANDARD
!
! ABSTRACT:
!
! Module for FORTRAN vector (dynamic array) operations.
! A Vector is a 2-Dimensional Array where the 1st
! dimension is static and the 2nd dimension is dynamic.
! Options for both 32-bit INTEGER (IntVector) and 64-bit
! REAL (RealVector) types.
! Also defines KIND=R8 for ~64-bit arithmetic on most
! standard machines.
!
! The dynamic memory allocation scheme is as follows.
! If VECTOR%LENGTH == 0, then no memory is allocated.
! If VECTOR%LENGTH overflows VECTOR%MAXLEN, then double
! the size of VECTOR%MAXLEN (unless VECTOR%MAXLEN == 0,
! then initialize to VECTOR%MAXLEN = 8).
! If VECTOR%LENGTH underflows VECTOR%MAXLEN, occupying
! less than half the total storage, reclaim half the
! size allocated to VECTOR.
!
! USAGE:
!
! The INTVECTOR and REALVECTOR types serve as
! 2-dimensional arrays for INTEGER and REAL(KIND=R8)
! types respectively.
! The R8 kind is defined herein and gives ~64-bit
! arithmetic on all known machines.
!
! To initialize a INTVECTOR type, use:
!    TYPE(INTVECTOR) VECTOR
!    VECTOR = INTVECTOR([DIM [, ISTAT]])
! where DIM specifies the size of the 1st (fixed)
! dimension. Similarly, to initilaize an REALVECTOR,
! use:
!    TYPE(REALVECTOR) VECTOR
!    VECTOR = REALVECTOR([DIM [, ISTAT]])
! From hereon, WLOG, both types are referenced as
! 'VECTOR'.
!
! All subroutines related to the Vector class use
! an optional error flag : ISTAT to report successful
! operations.
! The scheme is as follows:
! ISTAT = 0 : SUCCESS
! ISTAT < 0 : ILLEGAL INPUT AT ARG : (-ISTAT)
! ISTAT > 0 : MEMORY ALLOCATION/DEALLOCATION ERROR
!
! The following subroutines are used to manage and
! access the data in a VECTOR object. In all of the
! following, ITEM is either a REAL(KIND=R8) or INTEGER
! valued array, whose length matches the first (static)
! dimension of VECTOR, and IND is an INTEGER index whose
! value is between 1 and VECTOR%LENGTH.
!
! VECTOR%PUSH(ITEM [, ISTAT]) pushes ITEM to the end
! of VECTOR, resizing if necessarry.
!
! VECTOR%POP(ITEM [, ISTAT]) pops the top item off the
! back of VECTOR, resizing if necessarry, and returns
! the value in ITEM.
!
! VECTOR%INSERT(ITEM, IND [, ISTAT]) inserts ITEM at
! location IND.
!
! VECTOR%DELETE(IND [, ISTAT]) deletes the item at
! location IND.
!
! VECTOR%SET(IND, ITEM [, ISTAT]) sets the value of
! the data at location IND to ITEM.
!
! VECTOR%ITEM(IND [, ISTAT]) returns the data at
! location IND as an array.
!
! VECTOR%DATA() returns the entire data container at
! for VECTOR (a 2-dimensional array).
!
! VECTOR%LENGTH() returns the length of the second
! (dynamic) dimension.
!
! VECTOR%DIM() returns the length of the first (static)
! dimension.
!
! VECTOR%FREE() frees all allocated memory associated
! with VECTOR, resetting it to a new object.

MODULE VECTOR_CLASS

PRIVATE
PUBLIC :: INTVECTOR, REALVECTOR, R8

! Hompack type for 64-bit real numbers
INTEGER, PARAMETER :: R8 = SELECTED_REAL_KIND(13)

! Abstract Vector type
TYPE, ABSTRACT :: VECTOR
   ! private meta data
   INTEGER, PRIVATE :: D, N, MAXLEN
CONTAINS
   PROCEDURE, PASS :: LENGTH => VECTORSIZE
   PROCEDURE, PASS :: DIM => VECTORDIM
END TYPE VECTOR

! Integer Vector type (dynamic array)
TYPE, EXTENDS(VECTOR) :: INTVECTOR
   ! private data
   INTEGER, ALLOCATABLE, PRIVATE :: DAT(:,:)
CONTAINS
   PROCEDURE, PASS :: PUSH => INTVECTORPUSH
   PROCEDURE, PASS :: POP => INTVECTORPOP
   PROCEDURE, PASS :: INSERT => INTVECTORINS
   PROCEDURE, PASS :: DELETE => INTVECTORDEL
   PROCEDURE, PASS :: SET => INTVECTORSET
   PROCEDURE, PASS :: ITEM => INTVECTORITEM
   PROCEDURE, PASS :: DATA => INTVECTORDATA
   PROCEDURE, PASS :: FREE => INTVECTORFREE
END TYPE INTVECTOR

! Real 64-bit Vector type (dynamic array)
TYPE, EXTENDS(VECTOR) :: REALVECTOR
   ! data
   REAL(KIND=R8), ALLOCATABLE, PRIVATE :: DAT(:,:)
CONTAINS
   PROCEDURE, PASS :: PUSH => REALVECTORPUSH
   PROCEDURE, PASS :: POP => REALVECTORPOP
   PROCEDURE, PASS :: INSERT => REALVECTORINS
   PROCEDURE, PASS :: DELETE => REALVECTORDEL
   PROCEDURE, PASS :: SET => REALVECTORSET
   PROCEDURE, PASS :: ITEM => REALVECTORITEM
   PROCEDURE, PASS :: DATA => REALVECTORDATA
   PROCEDURE, PASS :: FREE => REALVECTORFREE
END TYPE REALVECTOR

! Constructor interfaces.
INTERFACE INTVECTOR
   MODULE PROCEDURE NEWINTVECTOR
END INTERFACE INTVECTOR

INTERFACE REALVECTOR
   MODULE PROCEDURE NEWREALVECTOR
END INTERFACE REALVECTOR

CONTAINS

! --- Generic procedures for Vector base type --- !

! check vector length
FUNCTION VECTORSIZE(VEC) RESULT(SIZE)
IMPLICIT NONE
! parameters
CLASS(VECTOR), INTENT(IN) :: VEC
INTEGER :: SIZE
! get size
SIZE = VEC%N
RETURN
END FUNCTION VECTORSIZE

! check vector length
FUNCTION VECTORDIM(VEC) RESULT(DIM)
IMPLICIT NONE
! parameters
CLASS(VECTOR), INTENT(IN) :: VEC
INTEGER :: DIM
! get size
DIM = VEC%D
RETURN
END FUNCTION VECTORDIM

! --- Procedures for IntVector type --- !

! constructor
FUNCTION NEWINTVECTOR(DIM, ISTAT) RESULT(VEC)
IMPLICIT NONE
! parameters
INTEGER, OPTIONAL, INTENT(IN) :: DIM
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
TYPE(INTVECTOR) :: VEC
! set information
VEC%N = 0
VEC%MAXLEN = 0
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for optionals
IF(PRESENT(DIM)) THEN
   IF (DIM < 1) THEN
      IF(PRESENT(ISTAT)) ISTAT = -1
      RETURN
   END IF
   VEC%D = DIM
ELSE
   VEC%D = 1
END IF
RETURN
END FUNCTION NEWINTVECTOR

! push function
SUBROUTINE INTVECTORPUSH(VEC, ITEM, ISTAT)
IMPLICIT NONE
! parameters
CLASS(INTVECTOR), INTENT(INOUT) :: VEC
INTEGER, INTENT(IN) :: ITEM(:)
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local data
INTEGER :: TMP(VEC%D,VEC%N), LSTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for illegal size
IF(VEC%D .NE. SIZE(ITEM)) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! no resizing required
IF(VEC%N < VEC%MAXLEN) THEN
   ! increment counter and add
   VEC%N = VEC%N + 1
   VEC%DAT(:,VEC%N) = ITEM(:)
! needs to be initialized
ELSE IF(VEC%MAXLEN .EQ. 0) THEN
   ! allocate
   ALLOCATE(VEC%DAT(VEC%D,8), STAT=LSTAT)
   IF(LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = 8
   ! increment counter and add
   VEC%N = VEC%N + 1
   VEC%DAT(:,VEC%N) = ITEM(:)
! resize data
ELSE
   ! save current data
   TMP(:,:) = VEC%DAT(:,1:VEC%N)
   ! reallocate
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF(LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   ALLOCATE(VEC%DAT(VEC%D,VEC%MAXLEN*2), &
      STAT=LSTAT)
   IF(LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = VEC%MAXLEN*2
   ! restore current data
   VEC%DAT(:,1:VEC%N) = TMP(:,:)
   ! add new data
   VEC%N = VEC%N + 1
   VEC%DAT(:,VEC%N) = ITEM(:)
END IF
RETURN
END SUBROUTINE INTVECTORPUSH

! pop function
SUBROUTINE INTVECTORPOP(VEC, ITEM, ISTAT)
IMPLICIT NONE
! parameters
CLASS(INTVECTOR), INTENT(INOUT) :: VEC
INTEGER, INTENT(OUT) :: ITEM(:)
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local variables
INTEGER :: TMP(VEC%D, VEC%N-1), LSTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for illegal size
IF(VEC%D .NE. SIZE(ITEM)) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! check for empty vector
IF(VEC%N .EQ. 0) THEN
   ITEM = 0
   RETURN
END IF
! get item
ITEM(:) = VEC%DAT(:,VEC%N)
VEC%N = VEC%N - 1
! reclaim partial memory
IF (VEC%N < VEC%MAXLEN / 2 .AND. &
  VEC%N > 6) THEN
   ! save current data
   TMP(:,:) = VEC%DAT(:,1:VEC%N)
   ! free
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT=LSTAT
      RETURN
   END IF
   ! reallocate
   ALLOCATE(VEC%DAT(VEC%D, VEC%MAXLEN / 2), STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT=LSTAT
      RETURN
   END IF
   VEC%MAXLEN = VEC%MAXLEN / 2
   ! copy back
   VEC%DAT(:,1:VEC%N) = TMP(:,:)
! reclaim all memory
ELSE IF (VEC%N .EQ. 0) THEN
   ! FREE
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT=LSTAT
      RETURN
   END IF
   VEC%MAXLEN = 0
END IF
RETURN
END SUBROUTINE INTVECTORPOP

! insert function
SUBROUTINE INTVECTORINS(VEC, ITEM, IND, ISTAT)
IMPLICIT NONE
! parameters
CLASS(INTVECTOR), INTENT(INOUT) :: VEC
INTEGER, INTENT(IN) :: ITEM(:), IND
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local data
INTEGER :: TMP(VEC%D,VEC%N), LSTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for illegal size
IF(VEC%D .NE. SIZE(ITEM)) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! check for bad index
IF(IND < 1 .OR. IND > VEC%N) THEN
   IF(PRESENT(ISTAT)) ISTAT = -2
   RETURN
END IF
! no resizing required
IF(VEC%N < VEC%MAXLEN) THEN
   ! increment counter and insert
   VEC%DAT(:,IND+1:VEC%N+1) = &
      VEC%DAT(:,IND:VEC%N)
   VEC%DAT(:,IND) = ITEM(:)
   VEC%N = VEC%N + 1
! resize data
ELSE
   ! save current data
   TMP(:,:) = VEC%DAT(:,1:VEC%N)
   ! reallocate
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF(LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   ALLOCATE(VEC%DAT(VEC%D,VEC%MAXLEN*2), STAT=LSTAT)
   IF(LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN=VEC%MAXLEN*2
   ! restore current data
   VEC%DAT(:,1:IND-1) = TMP(:,1:IND-1)
   VEC%DAT(:,IND+1:VEC%N+1) = TMP(:,IND:VEC%N)
   ! insert new data
   VEC%N = VEC%N + 1
   VEC%DAT(:,IND) = ITEM(:)
END IF
RETURN
END SUBROUTINE INTVECTORINS

! delete function
SUBROUTINE INTVECTORDEL(VEC, IND, ISTAT)
IMPLICIT NONE
! parameters
CLASS(INTVECTOR), INTENT(INOUT) :: VEC
INTEGER, INTENT(IN) :: IND
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local data
INTEGER :: TMP(VEC%D,VEC%N-1), LSTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for bad input
IF (IND < 1 .OR. IND > VEC%N) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! shift other elements down
VEC%DAT(:,IND:VEC%N-1) = VEC%DAT(:,IND+1:VEC%N)
VEC%N = VEC%N - 1
! reclaim partial memory
IF (VEC%N < VEC%MAXLEN / 2 .AND. &
  VEC%N > 6) THEN
   ! save current data
   TMP(:,:) = VEC%DAT(:,1:VEC%N)
   ! free
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   ! reallocate
   ALLOCATE(VEC%DAT(VEC%D, VEC%MAXLEN / 2), STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = VEC%MAXLEN / 2
   ! copy back
   VEC%DAT(:,1:VEC%N) = TMP(:,:)
! reclaim all memory
ELSE IF (VEC%N .EQ. 0) THEN
   ! free
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = 0
END IF
RETURN
END SUBROUTINE INTVECTORDEL

! set the value of VEC at IND to ITEM
SUBROUTINE INTVECTORSET(VEC, IND, ITEM, ISTAT)
IMPLICIT NONE
! parameters
CLASS(INTVECTOR), INTENT(INOUT) :: VEC
INTEGER, INTENT(IN) :: IND
INTEGER, INTENT(IN) :: ITEM(:)
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for bad input
IF (IND < 1 .OR. IND > VEC%N) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
IF (VEC%D .NE. SIZE(ITEM)) THEN
   IF(PRESENT(ISTAT)) ISTAT = -2
   RETURN
END IF
! set VEC%DAT(:,IND) to ITEM
VEC%DAT(:,IND) = ITEM(:)
RETURN
END SUBROUTINE INTVECTORSET

! memory access function (single item)
FUNCTION INTVECTORITEM(VEC, IND, ISTAT) RESULT(ITEM)
IMPLICIT NONE
! parameters
CLASS(INTVECTOR), INTENT(IN) :: VEC
INTEGER, INTENT(IN) :: IND
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
INTEGER :: ITEM(VEC%D)
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for bad input
IF (IND < 1 .OR. IND > VEC%N) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! get item
ITEM = VEC%DAT(:,IND)
RETURN
END FUNCTION INTVECTORITEM

! memory access function (all data)
FUNCTION INTVECTORDATA(VEC) RESULT(DAT)
IMPLICIT NONE
! parameters
CLASS(INTVECTOR), INTENT(IN) :: VEC
INTEGER :: DAT(VEC%D, VEC%N)
! get data
DAT(:,:) = VEC%DAT(:,1:VEC%N)
RETURN
END FUNCTION INTVECTORDATA

! free memory
SUBROUTINE INTVECTORFREE(VEC, ISTAT)
IMPLICIT NONE
! parameters
CLASS(INTVECTOR), INTENT(INOUT) :: VEC
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local variables
INTEGER :: LSTAT
! free data
IF (ALLOCATED(VEC%DAT)) THEN
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF(PRESENT(ISTAT)) ISTAT=LSTAT
END IF
RETURN
END SUBROUTINE INTVECTORFREE

! --- Functions for RealVector type --- !

! constructor
FUNCTION NEWREALVECTOR(DIM, ISTAT) RESULT(VEC)
IMPLICIT NONE
! parameters
INTEGER, OPTIONAL, INTENT(IN) :: DIM
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
TYPE(REALVECTOR) :: VEC
! set information
VEC%N = 0
VEC%MAXLEN = 0
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for optionals
IF(PRESENT(DIM)) THEN
   IF (DIM < 1) THEN
      IF(PRESENT(ISTAT)) ISTAT = -1
      RETURN
   END IF
   VEC%D = DIM
ELSE
   VEC%D = 1
END IF
RETURN
END FUNCTION NEWREALVECTOR

! push function
SUBROUTINE REALVECTORPUSH(VEC, ITEM, ISTAT)
IMPLICIT NONE
! parameters
CLASS(REALVECTOR), INTENT(INOUT) :: VEC
REAL(KIND=R8), INTENT(IN) :: ITEM(:)
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local data
REAL(KIND=R8) :: TMP(VEC%D,VEC%N)
INTEGER :: LSTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for illegal size
IF(VEC%D .NE. SIZE(ITEM)) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! no resizing required
IF(VEC%N < VEC%MAXLEN) THEN
   ! increment counter and add
   VEC%N = VEC%N + 1
   VEC%DAT(:,VEC%N) = ITEM(:)
! needs to be initialized
ELSE IF(VEC%MAXLEN .EQ. 0) THEN
   ! allocate
   ALLOCATE(VEC%DAT(VEC%D,8), STAT=LSTAT)
   IF(LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = 8
   ! increment counter and add
   VEC%N = VEC%N + 1
   VEC%DAT(:,VEC%N) = ITEM(:)
! resize data
ELSE
   ! save current data
   TMP(:,:) = VEC%DAT(:,1:VEC%N)
   ! reallocate
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF(LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   ALLOCATE(VEC%DAT(VEC%D,VEC%MAXLEN*2), &
      STAT=LSTAT)
   IF(LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN=VEC%MAXLEN*2
   ! restore current data
   VEC%DAT(:,1:VEC%N) = TMP(:,:)
   ! add new data
   VEC%N = VEC%N + 1
   VEC%DAT(:,VEC%N) = ITEM(:)
END IF
RETURN
END SUBROUTINE REALVECTORPUSH

! pop function
SUBROUTINE REALVECTORPOP(VEC, ITEM, ISTAT)
IMPLICIT NONE
! parameters
CLASS(REALVECTOR), INTENT(INOUT) :: VEC
REAL(KIND=R8), INTENT(OUT) :: ITEM(:)
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local variables
REAL(KIND=R8) :: TMP(VEC%D, VEC%N-1)
INTEGER :: LSTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for illegal size
IF(VEC%D .NE. SIZE(ITEM)) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! check for illegal length
IF(VEC%N .EQ. 0) THEN
   ITEM = 0
   RETURN
END IF
! get item
ITEM(:) = VEC%DAT(:,VEC%N)
VEC%N = VEC%N - 1
! reclaim partial memory
IF (VEC%N < VEC%MAXLEN / 2 .AND. &
  VEC%N > 6) THEN
   ! save current data
   TMP(:,:) = VEC%DAT(:,1:VEC%N)
   ! free
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   ! reallocate
   ALLOCATE(VEC%DAT(VEC%D, VEC%MAXLEN / 2), STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = VEC%MAXLEN / 2
   ! copy back
   VEC%DAT(:,1:VEC%N) = TMP(:,:)
! reclaim all memory
ELSE IF (VEC%N .EQ. 0) THEN
   ! free
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = 0
END IF
RETURN
END SUBROUTINE REALVECTORPOP

! insert function
SUBROUTINE REALVECTORINS(VEC, ITEM, IND, ISTAT)
IMPLICIT NONE
! parameters
CLASS(REALVECTOR), INTENT(INOUT) :: VEC
REAL(KIND=R8), INTENT(IN) :: ITEM(:)
INTEGER, INTENT(IN) :: IND
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local data
REAL(KIND=R8) :: TMP(VEC%D,VEC%N)
INTEGER :: LSTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for illegal size
IF(VEC%D .NE. SIZE(ITEM)) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! check for bad index
IF(IND < 1 .OR. IND > VEC%N) THEN
   IF(PRESENT(ISTAT)) ISTAT = -2
   RETURN
END IF
! no resizing required
IF(VEC%N < VEC%MAXLEN) THEN
   ! increment counter and insert
   VEC%DAT(:,IND+1:VEC%N+1) = &
      VEC%DAT(:,IND:VEC%N)
   VEC%DAT(:,IND) = ITEM(:)
   VEC%N = VEC%N + 1
! resize data
ELSE
   ! save current data
   TMP(:,:) = VEC%DAT(:,1:VEC%N)
   ! reallocate
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   ALLOCATE(VEC%DAT(VEC%D,VEC%MAXLEN*2), STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN=VEC%MAXLEN*2
   ! restore current data
   VEC%DAT(:,1:IND-1) = TMP(:,1:IND-1)
   VEC%DAT(:,IND+1:VEC%N+1) = TMP(:,IND:VEC%N)
   ! insert new data
   VEC%N = VEC%N + 1
   VEC%DAT(:,IND) = ITEM(:)
END IF
RETURN
END SUBROUTINE RealVectorIns

! delete function
SUBROUTINE REALVECTORDEL(VEC, IND, ISTAT)
IMPLICIT NONE
! parameters
CLASS(REALVECTOR), INTENT(INOUT) :: VEC
INTEGER, INTENT(IN) :: IND
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local data
REAL(KIND=R8) :: TMP(VEC%D,VEC%N-1)
INTEGER :: LSTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for bad input
IF (IND < 1 .OR. IND > VEC%N) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! shift other elements down
VEC%DAT(:,IND:VEC%N-1) = VEC%DAT(:,IND+1:VEC%N)
VEC%N = VEC%N - 1
! reclaim partial memory
IF (VEC%N < VEC%MAXLEN / 2 .AND. &
  VEC%N > 6) THEN
   ! save current data
   TMP(:,:) = VEC%DAT(:,1:VEC%N)
   ! free
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   ! reallocate
   ALLOCATE(VEC%DAT(VEC%D, VEC%MAXLEN / 2), STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = VEC%MAXLEN / 2
   ! copy back
   VEC%DAT(:,1:VEC%N) = TMP(:,:)
! reclaim all memory
ELSE IF (VEC%N .EQ. 0) THEN
   ! free
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF (LSTAT .NE. 0) THEN
      IF(PRESENT(ISTAT)) ISTAT = LSTAT
      RETURN
   END IF
   VEC%MAXLEN = 0
END IF
RETURN
END SUBROUTINE REALVECTORDEL

! set the value of VEC at IND to ITEM
SUBROUTINE REALVECTORSET(VEC, IND, ITEM, ISTAT)
IMPLICIT NONE
! parameters
CLASS(REALVECTOR), INTENT(INOUT) :: VEC
INTEGER, INTENT(IN) :: IND
REAL(KIND=R8), INTENT(IN) :: ITEM(:)
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for bad input
IF (IND < 1 .OR. IND > VEC%N) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
IF (VEC%D .NE. SIZE(ITEM)) THEN
   IF(PRESENT(ISTAT)) ISTAT = -2
   RETURN
END IF
! set VEC%DAT(:,IND) to ITEM
VEC%DAT(:,IND) = ITEM(:)
RETURN
END SUBROUTINE REALVECTORSET

! memory access function (single item)
FUNCTION REALVECTORITEM(VEC, IND, ISTAT) RESULT(ITEM)
IMPLICIT NONE
! parameters
CLASS(REALVECTOR), INTENT(IN) :: VEC
INTEGER, INTENT(IN) :: IND
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
REAL(KIND=R8) :: ITEM(VEC%D)
! initialize ISTAT
IF(PRESENT(ISTAT)) ISTAT = 0
! check for bad input
IF (IND < 1 .OR. IND > VEC%N) THEN
   IF(PRESENT(ISTAT)) ISTAT = -1
   RETURN
END IF
! get item
ITEM = VEC%DAT(:,IND)
RETURN
END FUNCTION REALVECTORITEM

! memory access function (all data)
FUNCTION REALVECTORDATA(VEC) RESULT(DAT)
IMPLICIT NONE
! parameters
CLASS(REALVECTOR), INTENT(IN) :: VEC
REAL(KIND=R8) :: DAT(VEC%D, VEC%N)
! retrieve data
DAT(:,:) = VEC%DAT(:,1:VEC%N)
RETURN
END FUNCTION REALVECTORDATA

! free memory
SUBROUTINE REALVECTORFREE(VEC, ISTAT)
IMPLICIT NONE
! parameters
CLASS(REALVECTOR), INTENT(INOUT) :: VEC
INTEGER, OPTIONAL, INTENT(OUT) :: ISTAT
! local data
INTEGER :: LSTAT
! free data
IF (ALLOCATED(VEC%DAT)) THEN
   DEALLOCATE(VEC%DAT, STAT=LSTAT)
   IF(PRESENT(ISTAT)) ISTAT = LSTAT
END IF
RETURN
END SUBROUTINE REALVECTORFREE

END MODULE VECTOR_CLASS


! Check that lbound() and ubound() work correctly for assumed shapes.
! { dg-do run }
program main
  integer, dimension (40, 80) :: a = 1
  call test (a)
contains
  subroutine test (b)
    integer, dimension (11:, -8:), target :: b
    integer, dimension (:, :), pointer :: ptr

    if (lbound (b, 1) .ne. 11) call abort
    if (ubound (b, 1) .ne. 50) call abort
    if (lbound (b, 2) .ne. -8) call abort
    if (ubound (b, 2) .ne. 71) call abort

    if (lbound (b (:, :), 1) .ne. 1) call abort
    if (ubound (b (:, :), 1) .ne. 40) call abort
    if (lbound (b (:, :), 2) .ne. 1) call abort
    if (ubound (b (:, :), 2) .ne. 80) call abort

    if (lbound (b (20:30:3, 40), 1) .ne. 1) call abort
    if (ubound (b (20:30:3, 40), 1) .ne. 4) call abort

    ptr => b
    if (lbound (ptr, 1) .ne. 1) call abort
    if (ubound (ptr, 1) .ne. 40) call abort
    if (lbound (ptr, 2) .ne. 1) call abort
    if (ubound (ptr, 2) .ne. 80) call abort
  end subroutine test
end program main


!
! MAIN PROGRAM HERE.  This is just an example so you know
! how to use it.
!

module time_kdtree
  use kd_tree
contains

  real function time_search(tree,nsearch,mode, nn, r2)
    !
    !  Return CPU time, in seconds, for searching 'nsearch' reference points
    !  using any specific search mode.
    !

    type(tree_master_record), pointer :: tree
    integer, intent(in)               :: nsearch ! how many reference points
    integer, intent(in)               :: mode    ! what kind of search
    integer, intent(in)               :: nn      ! number of neighbors
    real, intent(in)                  :: r2      ! radius^2
    !
    real    :: qv(tree%dim), rv               ! query vector, random variate
    integer :: i, random_loc
    real    :: t0, t1
    real, pointer    :: dists(:)
    integer, pointer :: inds(:)
    real(kind(0.0d0)) :: nftotal

    call cpu_time(t0)   ! get initial time.
    nftotal = 0.0
    allocate(dists(nn))
    allocate(inds(nn) )
    do i=1,nsearch

       select case (mode)
       case (1)
          !
          !  Fixed NN search around randomly chosen point
          !
          call random_number(qv)
          call n_nearest_to(tp=tree,qv=qv,n=nn,indexes=inds,distances=dists)
       case (2)
          !
          ! Fixed NN seasrch around randomly chosen point in dataset
          ! with 100 correlation time
          !
          call random_number(rv)
          random_loc = floor(rv*tree%n) + 1
          call n_nearest_to_around_point(tp=tree,idxin=random_loc,&
           correltime=100,n=nn,indexes=inds,distances=dists)
       case default
          write (*,*) 'Search type ', mode, ' not implemented.'
          time_search = -1.0 ! invalid
          return
       end select

    enddo
    call cpu_time(t1)

    time_search = t1-t0
    if (nftotal .gt. 0.0) then
!       write (*,*) 'Average number of neighbors found = ', nftotal / real(nsearch)
    endif
    deallocate(inds,dists)
    return
  end function time_search

  real function searches_per_second(tree,mode,nn,r2) result(res)
    !
    !
    ! return estimated number of searches per second.
    ! Will call "time_search" with increasing numbers of reference points
    ! until CPU time taken is at least 1 second.
    !

    type(tree_master_record), pointer :: tree
    integer, intent(in)               :: mode    ! what kind of search
    integer, intent(in)               :: nn      ! number of neighbors
    real, intent(in)                  :: r2      ! radius^2
    !
    integer :: nsearch
    real    :: time_taken

    nsearch = 50  ! start with 50 reference points
    do
       time_taken = time_search(tree,nsearch,mode,nn,r2)
       if (time_taken .lt. 1.0) then
          nsearch = nsearch * 5
          cycle
       else
          res = real(nsearch) / time_taken
          return
       end if
    end do
    return
  end function searches_per_second

end module time_kdtree

Program kd_tree_test
  Use kd_tree  ! this is how you get access to the k-d tree routines
  use time_kdtree

  Integer :: n, d
  Real, Dimension(:,:), Allocatable :: my_array

  Type(tree_master_record), Pointer :: tree
  ! this is how you declare a tree in your main program

  Integer :: k, j

  Real, Allocatable :: query_vec(:)
  Real,allocatable     :: dists(:), distsb(:)
  Integer,allocatable   :: inds(:), indsb(:)
  integer :: nnbrute
  real      :: t0, t1, sps

  integer, parameter  :: nnn = 5
  integer,parameter   :: nnarray(nnn) =(/ 1, 5, 10, 25, 500 /)
  integer, parameter  :: nr2 = 5

  real      :: r2array(nr2)
  parameter (r2array = (/  1.0e-4,1.0e-3,5.0e-3,1.0e-2,2.0e-2 /) )

  Print *, "Type in N and d"
  Read *, n, d

!  n = 250000
!  d = 3

  Allocate(my_array(n,d))
  allocate(query_vec(d))
  Call Random_number(my_array)  !fills entire array with built-in-randoms

  call cpu_time(t0)
  tree => create_tree(my_array) ! this is how you create a tree.
  call cpu_time(t1)
  write (*,*) real(n)/real(t1-t0), ' points per second built for regular tree.'

  nnbrute = 50
  allocate(dists(nnbrute),distsb(nnbrute))
  allocate(inds(nnbrute),indsb(nnbrute))

  Do k=1,50
     Call Random_number(query_vec)

     ! find five nearest neighbors to.
     inds = -666
     indsb = -777
     Call n_nearest_to(tp=tree, qv=query_vec, n=nnbrute, indexes=inds, distances=dists)

     call n_nearest_to_brute_force(tree, query_vec, nnbrute, indsb, distsb)
     if (ANY(indsb(1:nnbrute) .ne. inds(1:nnbrute)) .or. &
       any(dists(1:nnbrute) .ne. distsb(1:nnbrute))) then
        write (*,*) 'MISMATCH! @ k=',k

        do j=1,nnbrute
           write (*,*) j,'Tree/brute ids=',inds(j),indsb(j)
           write (*,*) j,'tree/brute dists=', dists(j), distsb(j)
!           write (*,*) j,'my dist to tree = ',  &
!            square_distance(d,my_array(:,inds(j)),query_vec)
!           write (*,*) j,'my dist to brute = ',  &
!            square_distance(d,my_array(:,indsb(j)),query_vec)

        enddo

        print *, "Tree indexes = ", inds(1:nnbrute)

        print *, "Brute indexes = ", indsb(1:nnbrute)
        print *, "Tree distances = ", dists(1:nnbrute)
        print *, "Brute distances = ", distsb(1:nnbrute)
     endif

  Enddo

10 format('R^2 search, r2/d=',G10.2,':',F13.0,A)

20 format(A,' NN=',I7,':',F10.0,' searches/s in ',A)

  do k=1,nnn
     sps =searches_per_second(tree,1,nnarray(k),1.0)
     write (*,20) 'Random pts',nnarray(k),sps,'old regular tree.'
  enddo

  do k=1,nnn
     sps = searches_per_second(tree,2,nnarray(k),1.0)
     write (*,20) 'in-data pts',nnarray(k),sps,'old tree.'
  enddo

  Call destroy_tree(tree)
  ! this releases memory for the tree BUT NOT THE ARRAY OF DATA YOU PASSED
  ! TO MAKE THE TREE.

  Deallocate(my_array)
  ! deallocate the memory for the data.

End Program kd_tree_test


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                                !!
!!  This file is part of SciFT project                                               !!
!!  Copyright (c) 2011-2016 Nestor F. Aguirre (nfaguirrec@gmail.com)                 !!
!!                                                                                !!
!!  Redistribution and use in source and binary forms, with or without               !!
!!  modification, are permitted provided that the following conditions are met:      !!
!!                                                                                !!
!!  1. Redistributions of source code must retain the above copyright notice, this   !!
!!     list of conditions and the following disclaimer.                              !!
!!  2. Redistributions in binary form must reproduce the above copyright notice,     !!
!!     this list of conditions and the following disclaimer in the documentation     !!
!!     and/or other materials provided with the distribution.                        !!
!!  3. Neither the name of the copyright holders nor the names of its contributors   !!
!!     may be used to endorse or promote products derived from this software         !!
!!     without specific prior written permission.                                    !!
!!                                                                                !!
!!  The copyright holders provide no reassurances that the source code provided      !!
!!  does not infringe any patent, copyright, or any other intellectual property      !!
!!  rights of third parties.  The copyright holders disclaim any liability to any    !!
!!  recipient for claims brought against recipient by any third party for            !!
!!  infringement of that parties intellectual property rights.                       !!
!!                                                                                !!
!!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND  !!
!!  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED    !!
!!  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE           !!
!!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR  !!
!!  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES   !!
!!  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;     !!
!!  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND      !!
!!  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT       !!
!!  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS    !!
!!  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                     !!
!!                                                                                !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!>
!! @brief Test program
!!
!! E0=0.05; omega=0.20279; t0=500.0; w=800.0; dw=100.0; tMax=1000.0
!! echo "n=2**11; x0=0.0; h=$tMax/(n-1); do for [i=1:n] { x=x0+(i-1)*h; print sprintf( '%10.5f%10.5f', x, $E0*cos($omega*x)*erfhat(x,$t0,$w,$dw) ); }" | gnuplot 2> signalErfHat.dat
!! ./fft1D -i signalErfHat.dat > fftErfHat.dat
!! plot "signalErfHat.dat" w lp pt 7 ps 0.5 lw 2
!! plot [0:0.4] "fftErfHat.dat" w lp pt 7 ps 0.5 lw 2
!!
!! echo "n=2**11; x0=0.0; h=$tMax/(n-1); do for [i=1:n] { x=x0+(i-1)*h; print sprintf( '%10.5f%10.5f', x, $E0*cos($omega*x)*coshat(x,$t0,$w,$dw) ); }" | gnuplot 2> signalCosHat.dat
!! ./fft1D -i signalCosHat.dat > fftCosHat.dat
!! plot "signalCosHat.dat" w lp pt 7 ps 0.5 lw 2
!! plot [0:0.4] "fftCosHat.dat" w lp pt 7 ps 0.5 lw 2
!!
!! plot "signalErfHat.dat" w l lw 2, "signalCosHat.dat" w l lw 2 lt 3
!! set size square
!! plot [0:0.4] "fftErfHat.dat" w lp pt 7 ps 0.5 lw 2, "fftCosHat.dat" w lp pt 7 ps 0.5 lw 2 lt 3
!!
program main
	use GOptions_
	use IOStream_
	use String_
	use CommandLineParser_
	use Spline_
	use RNFunction_
	use CNFunction_
	use FourierTransform_
	implicit none

	type(String) :: iFileName
	type(String) :: oFileName
	type(IFStream) :: ifile
	type(CNFunction) :: nFunc, FnFunc
	type(RNFunction) :: spectrum
	type(String) :: strBuffer
	type(CommandLineParser) :: parser
	integer :: fftSgn

	character(5), allocatable :: tokens(:)
	integer, allocatable :: columns(:)
	integer :: nPoints
	integer :: smoothFactor
	integer :: i

	type(String) :: typeOfSpectrum
	integer :: idTypeOfSpectrum

	type(String) :: typeOfMethod
	integer :: idTypeOfMethod

	type(String) :: typeWindow
	integer :: idTypeWindow
	real(8) :: paramWindow
	logical :: centeredWindow
	character(100) :: oFileWindow

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	! General parameters
	! -i
	! -o
	! -c
	! -n
	!-----------------------------------------------------------------
	iFileName = parser.getString( "-i" )
	oFileName = parser.getString( "-o" )

	strBuffer = parser.getString( "-s", def="FORWARD" )
	if( trim(strBuffer.fstr) == "FORWARD" ) then
		fftSgn = FourierTransform_FORWARD
	else if( trim(strBuffer.fstr) == "BACKWARD" ) then
		fftSgn = FourierTransform_BACKWARD
	else
		write(*,*) "### ERROR ### Bad value for parameter -s (FORWARD|BACKWARD)"
		stop
	end if

	strBuffer = parser.getString( "-c", def="1,2,3" )
	call strBuffer.split( tokens, "," )

	if( size(tokens) == 3 ) then
		allocate( columns(3) )
		columns = [ FString_toInteger(tokens(1)), FString_toInteger(tokens(2)), FString_toInteger(tokens(3)) ]
	else if( size(tokens) == 2 ) then
		allocate( columns(2) )
		columns = [ FString_toInteger(tokens(1)), FString_toInteger(tokens(2)) ]
	else
		write(*,*) "### ERROR ### Bad value for parameter -c"
		stop
	end if

	nPoints = parser.getInteger( "-n", def=-1 )
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	! Type of spectrum
	! -t
	!-----------------------------------------------------------------
	typeOfSpectrum = parser.getString( "-t", def="NORM" )

	select case( trim(typeOfSpectrum.fstr) )
		case( "NORM" )
			idTypeOfSpectrum = FourierTransform_NORM_SPECTRUM
		case( "REALPART" )
			idTypeOfSpectrum = FourierTransform_REALPART_SPECTRUM
		case( "IMAGPART" )
			idTypeOfSpectrum = FourierTransform_IMAGPART_SPECTRUM
		case( "PHASE" )
			idTypeOfSpectrum = FourierTransform_PHASE_SPECTRUM
		case( "POWER" )
			idTypeOfSpectrum = FourierTransform_POWER_SPECTRUM
		case( "FT" )
			idTypeOfSpectrum = -1
	end select
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	! Type of method
	! -m
	!-----------------------------------------------------------------
	typeOfMethod = parser.getString( "-m", def="FFT" )

	select case( trim(typeOfMethod.fstr) )
		case( "FFT" )
			idTypeOfMethod = FourierTransform_FFT_METHOD
		case( "NUMERICAL" )
			idTypeOfMethod = FourierTransform_NUMERICAL_METHOD
	end select
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	! Window parameters
	!-----------------------------------------------------------------
	typeWindow = parser.getString( "-tw", def="NONE" )

	select case( trim(typeWindow.fstr) )
		case( "NONE" )
			idTypeWindow = FourierTransform_WINDOW_NONE
			paramWindow = parser.getReal( "-pw", def=-1.0_8 )
		case( "COS" )
			idTypeWindow = FourierTransform_WINDOW_COS
			paramWindow = parser.getReal( "-pw", def=2.0_8 )
		case( "GAUSS" )
			idTypeWindow = FourierTransform_WINDOW_GAUSS
			paramWindow = parser.getReal( "-pw", def=4.0_8 )
		case( "ERF_TOPHAT" )
			idTypeWindow = FourierTransform_WINDOW_ERF_TOPHAT
			paramWindow = parser.getReal( "-pw", def=0.2_8 )
		case( "FLATTOP" )
			idTypeWindow = FourierTransform_WINDOW_FLATTOP
			paramWindow = parser.getReal( "-pw", def=0.0_8 )
	end select

	centeredWindow = parser.getLogical( "-cw", def=.false. )
	strBuffer = parser.getString( "-ow", def=FString_NULL )
	oFileWindow = strBuffer.fstr
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call ifile.init( iFileName.fstr )
	call nFunc.fromFStream( ifile, columns=columns )
	call ifile.close()

	if( idTypeOfSpectrum /= -1 ) then

		if( nPoints == -1 ) nPoints = nFunc.nPoints()

		spectrum = FourierTransform_spectrum( nFunc, sgn=fftSgn, type=idTypeOfSpectrum, method=idTypeOfMethod, &
							window=FourierTransform_Window( idTypeWindow, paramWindow, centeredWindow, trim(oFileWindow) ) )

		call spectrum.save( oFileName.fstr )
	else

		FnFunc = FourierTransform_fft( nFunc, sgn=fftSgn )
		call FnFunc.save( oFileName.fstr )

	end if

	deallocate( columns )

end program main


!
!	Print two-way marginal distribution.
!	itemname contains item names.
!	numcatobs counts observed categories.
!	unitmargin2 provides the unit for output.
!	resid indicates if residuals are displayed.
!	fitmarg2 is the fitted two-way marginal total.
!	fitpmarg2 is the fitted two-way marginal proportion.
!	obsmarg2 is the observed two-way marginal total.
!	obspmarg2 is the observed two-way marginal proportion.
!	presented2 counts weighted pairs of items presented.
!	residamarg2 is the adjusted residual.
!	residmarg2 is the residual for the two-way marginal total.
!	residpmarg2 is the residual for the two-way marginal proportion.
!	stdobsmarg2 is the standard deviation of the observed two-way marginal.
!	stdobspmarg2 is the asymptotic standard deviation of the observed
!		two-way marginal fraction.
!	stdresidmarg2 is the asymptotic standard error for the residual frequency.
!	stdresidpmarg2 is the asymptotic standard error for the residual proportion.

subroutine printmarginal2(itemname,numcatobs,unitmargin2,resid,&
	fitmarg2,fitpmarg2,obsmarg2,obspmarg2,presented2,&
	residamarg2,residmarg2,residpmarg2,&
	stdobsmarg2,stdobspmarg2,stdresidmarg2,stdresidpmarg2)
implicit none
character(len=32),intent(in)::itemname(:)
integer,intent(in)::numcatobs(:),unitmargin2
logical,intent(in)::resid
real(kind=8),intent(in)::fitmarg2(:,:),fitpmarg2(:,:),obsmarg2(:,:),&
		obspmarg2(:,:),presented2(:,:),residamarg2(:,:),residmarg2(:,:),&
		residpmarg2(:,:),stdobsmarg2(:,:),stdobspmarg2(:,:),&
		stdresidmarg2(:,:),stdresidpmarg2(:,:)
!	buff0, buff1, and buff are buffers.
character(len=12)::buff0,buff1
character(len=25)::buff(12)

!	cat counts categories, as does cat1.
!	counter counts positions, as does counter1.
!	io is the flag for output error.
!	item counts items, as does item1.
!	row counts rows.
integer::cat,cat1,counter,counter1,io,item,item1,row
!	var is a variance.
real(kind=8)::var
counter1=numcatobs(1)+1
write(unit=unitmargin2,fmt='(a)',iostat=io) 'Two-way marginal distribution of items'
if(io/=0) stop "Printing of two-way marginal distribution failed."
if(resid)then
	write(unit=unitmargin2,fmt='(31a)',iostat=io) "Item_name",",",&
		"Cat_no",",","Item_name",",",&
		"Cat_no",",","Item_pair_freq",",","Obs_cat_pair_freq",",","Std_err_obs_cat_pair_freq",",",&
		"Fit_cat_pair_freq",",","Obs_cat_pair_prop",",","Std_err_cat_pair_prop",",",&
		"Fit_cat_pair_prop",",",&
		"Res_cat_pair_freq",",","Std_err_res_cat_pair_freq",",",&
		"Res_cat_pair_prop",",","Std_err_res_cat_pair_prop",",",&
		"Adjusted_residual"
else
	write(unit=unitmargin2,fmt='(21a)',iostat=io) "Item_name",",",&
		"Cat_no",",","Item_name",",",&
		"Cat_no",",","Item_pair_freq",",","Obs_cat_pair_freq",",","Std_err_obs_cat_pair_freq",",",&
		"Fit_cat_pair_freq",",","Obs_cat_pair_prop",",","Std_err_cat_pair_prop",",",&
		"Fit_cat_pair_prop"

end if
do item1=2,size(itemname)
do cat1=1,numcatobs(item1)
write(buff0,'(i12)') cat1-1
counter=1
do item=1,item1-1

	do cat=1,numcatobs(item)
		write(buff1,'(i12)') cat-1
		write(buff(1),'(g25.16e3)') presented2(item,item1)
		write(buff(2),'(g25.16e3)') obsmarg2(counter,counter1)
		write(buff(3),'(g25.16e3)') stdobsmarg2(counter,counter1)
		write(buff(4),'(g25.16e3)') fitmarg2(counter,counter1)
		write(buff(5),'(g25.16e3)') obspmarg2(counter,counter1)
		write(buff(6),'(g25.16e3)') stdobspmarg2(counter,counter1)
		write(buff(7),'(g25.16e3)') fitpmarg2(counter,counter1)

		if(resid)then
			write(buff(8),'(g25.16e3)') residmarg2(counter,counter1)
			write(buff(9),'(g25.16e3)') stdresidmarg2(counter,counter1)
			write(buff(10),'(g25.16e3)') residpmarg2(counter,counter1)
			write(buff(11),'(g25.16e3)') stdresidpmarg2(counter,counter1)
			write(buff(12),'(g25.16e3)') residamarg2(counter,counter1)
			write(unit=unitmargin2,fmt='(31a)',iostat=io)trim(adjustl(itemname(item1))),",",trim(adjustl(buff0)),",",&
				trim(adjustl(itemname(item))),",",trim(adjustl(buff1)),&
				(",",trim(adjustl(buff(row))),row=1,12)
		else
			write(unit=unitmargin2,fmt='(21a)',iostat=io)trim(adjustl(itemname(item1))),",",trim(adjustl(buff0)),",",&
				trim(adjustl(itemname(item))),",",trim(adjustl(buff1)),&
				(",",trim(adjustl(buff(row))),row=1,7)
		end if
		if(io/=0) stop "Printing of marginal distribution failed."
		counter=counter+1
	end do

end do
counter1=counter1+1
end do
end do
return
end subroutine printmarginal2


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
! Junior University.  All rights reserved.                             %
!                                                                      %
! The programs in GSLIB are distributed in the hope that they will be  %
! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
! responsibility to anyone for the consequences of using them or for   %
! whether they serve any particular purpose or work at all, unless he  %
! says so in writing.  Everyone is granted permission to copy, modify  %
! and redistribute the programs in GSLIB, but only under the condition %
! that this notice and the above copyright notice remain intact.       %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The functions and subroutines below were modified from the
! version 2.0 of the gslib code written in fortran 77
!
! The objective is to add functionality to GSLIB and to link
! this code with python using f2py. It uses f90 code convention.
! The arrays are dynamic and externally declared (from python)
!
! the code was converted from Fortran 77 to Fortran 90 using F2F.pl
!
! for more information please refer to:
! - gslib77 source code: http://www.statios.com/software/gslib77_ls.tar.gz
! - GSLIB: Geostatistical Software Library and User's Guide. Second edition
!   by Clayton V. Deutsch, Andre G. Journel, 1997.
! - F2PY Users Guide: http://docs.scipy.org/doc/numpy-dev/f2py/
! - F2F https://bitbucket.org/lemonlab/f2f
!-----------------------------------------------------------------------

subroutine addcoord(nx, ny, nz, xmn, ymn, zmn, xsiz, ysiz, zsiz, xx, yy, zz)

    !
    !              Calculate coordinates of an ordered grid
    !              ****************************************
    ! INPUT VARIABLES:
    !
    !   nx, ny, nz           Number nodes in the grid
    !   xmn, ymn, zmn        Coordinate of the centroid (lower left corner)
    !   xsiz, ysiz, zsiz     Sizes of the cell/block
    !
    ! OUTPUT VARIABLES:
    !
    !   xx(n), yy(n), zz(n)  coordinate arrays with size n= nx*ny*nz
    !-----------------------------------------------------------------------

    real*8,  intent(in) :: xmn, ymn, zmn, xsiz, ysiz, zsiz
    integer, intent(in) :: nx, ny, nz
    real*8,    intent(out), dimension(nx*ny*nz) :: xx, yy, zz

    real*8 :: x, y, z
    integer :: i

    !
    ! Loop over grid
    !
    i=0
    do iz=1,nz
          z = zmn + dble(iz-1)*zsiz
          do iy=1,ny
                y = ymn + dble(iy-1)*ysiz
                do ix=1,nx
                      x = xmn + dble(ix-1)*xsiz
                      i=i+1
                      xx(i)=x
                      yy(i)=y
                      zz(i)=z
                end do
          end do
    end do

    return

end subroutine addcoord


! { dg-do compile }
! Tests the fix for PR25072, in which non-PURE functions could
! be referenced inside a FORALL mask.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
module foo
  integer, parameter :: n = 4
contains
  logical function foot (i)
    integer, intent(in) :: i
    foot = (i == 2) .or. (i == 3)
  end function foot
end module foo

  use foo
  integer :: i, a(n)
  logical :: s(n)

  a = 0
  forall (i=1:n, foot (i)) a(i) = i  ! { dg-error "non-PURE" }
  if (any (a .ne. (/0,2,3,0/))) call abort ()

  forall (i=1:n, s (i) .or. t(i)) a(i) = i  ! { dg-error "non-PURE|LOGICAL" }
  if (any (a .ne. (/0,3,2,1/))) call abort ()

  a = 0
  forall (i=1:n, mod (i, 2) == 0) a(i) = w (i)  ! { dg-error "non-PURE" }
  if (any (a .ne. (/0,2,0,4/))) call abort ()

contains
  logical function t(i)
    integer, intent(in) :: i
    t = (mod (i, 2) == 0)
  end function t
  integer function w(i)
    integer, intent(in) :: i
    w = 5 - i
  end function w
end
! { dg-final { cleanup-modules "foo" } }


      SUBROUTINE LUDCMP(NSIZ,N,A,INDX,WORK)
C     *******************************************************
C     *   Factors a full NxN matrix into an LU form.        *
C     *   Uses LINPACK routines for linear algebra          *
C     *******************************************************
C
      REAL A(NSIZ,NSIZ), WORK(NSIZ)
      INTEGER INDX(NSIZ)
C
      CALL SGETRF(N,NSIZ,A,NSIZ,INDX,INFO)
C
      RETURN
      END ! LUDCMP

      SUBROUTINE BAKSUB(NSIZ,N,A,INDX,B)
      DIMENSION A(NSIZ,NSIZ), B(NSIZ), INDX(NSIZ)
C     *******************************************************
C     *   BAKSUB does back-substitution with RHS using      *
C     *   stored LU decomposition.                          *
C     *   Uses LINPACK routines for linear algebra          *
C     *******************************************************
C
      MRHS = 1
      CALL SGETRS('N',N,MRHS,A,NSIZ,INDX,B,NSIZ,INFO)
C
      RETURN
      END ! BAKSUB