	SUBROUTINE enercalc(Nx,Ny,Nz,planbxy,planbz,planfxy,planfz,dt,Es,&
				modescalereal,enkin,enstr,enpot,en,mythreadid,numthreads,&
				lowxv,lowzv,upxv,upzv,kx,ky,kz,&
				temp1,temp2,vtemp1,vtemp2,v,vold,u,uold)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine program calculates the energy for the nonlinear
	! Klein-Gordon equation in 3 dimensions
	! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*|u|^2u
	!
	! The energy density is given by
	! 0.5u_t^2+0.5u_x^2+0.5u_y^2+0.5u_z^2+0.5u^2+Es*0.25u^4
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  planfxyz			= Forward 2d fft plan
	!  planbxyz			= Backward 2d fft plan
	!  dt				= timestep
	!  Es				= +1 for focusing, -1 for defocusing
	!  modescalereal	= Number to scale after backward FFT
	!  numthreads		= total number of OpenMP threads
	!  mythreadid		= thread number
	! .. Arrays ..
	!  u 				= approximate solution
	!  v 				= Fourier transform of approximate solution
	!  uold 			= approximate solution
	!  vold 			= Fourier transform of approximate solution
	!  temp1			= array to hold temporary values
	!  temp2			= array to hold temporary values
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  kz				= fourier frequencies in z direction
	!  lowxv			= array with entries of array to be used by each thread
	!  upxv				= array with entries of array to be used by each thread
	!  lowzv			= array with entries of array to be used by each thread
	!  upzv				= array with entries of array to be used by each thread
	!
	! OUTPUT
	!
	! .. Scalars ..
	!  enkin			= Kinetic energy
	!  enstr			= Strain energy
	!  enpot			= Potential energy
	!  en				= Total energy
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 	FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! 	OpenMP library
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)		:: Nx,Ny,Nz,numthreads,mythreadid
	INTEGER(KIND=4), DIMENSION(1:numthreads), INTENT(IN) :: &
												lowxv,upxv,lowzv,upzv
	REAL(KIND=8), INTENT(IN)						:: dt,Es,modescalereal
	INTEGER(KIND=8), INTENT(IN)						:: planbxy,planbz,planfxy,planfz
	COMPLEX(KIND=8), DIMENSION(1:Nx),INTENT(IN)		:: kx
	COMPLEX(KIND=8), DIMENSION(1:Ny),INTENT(IN)		:: ky
	COMPLEX(KIND=8), DIMENSION(1:Nz),INTENT(IN)		:: kz
	COMPLEX(KIND=8), DIMENSION(1:Nx,1:Ny,1:Nz),INTENT(IN)	:: u,uold
	COMPLEX(KIND=8), DIMENSION(1:Nz,1:Ny,1:Nx),INTENT(IN)	:: v,vold
	COMPLEX(KIND=8), DIMENSION(1:Nx,1:Ny,1:Nz),INTENT(INOUT)	:: temp1,vtemp1
	COMPLEX(KIND=8), DIMENSION(1:Nz,1:Ny,1:Nx),INTENT(INOUT)	:: temp2,vtemp2
	REAL(KIND=8), INTENT(OUT)							:: enkin,enstr
	REAL(KIND=8), INTENT(OUT)							:: enpot,en
	INTEGER(KIND=4)										:: i,j,k

	!.. Strain energy ..
	DO i=lowxv(mythreadid),upxv(mythreadid)
		DO j=1,Ny
			DO k=1,Nz
				temp2(k,j,i)=0.5d0*kx(i)*(vold(k,j,i)+v(k,j,i))
			END DO
		END DO
	END DO
	!$OMP FLUSH
	CALL backwardfft(Nx,Ny,Nz,planbz,planbxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,temp2,temp1,vtemp1,vtemp2)

	DO k=lowzv(mythreadid),upzv(mythreadid)
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=abs(temp1(i,j,k)*modescalereal)**2
			END DO
		END DO
	END DO
	!$OMP FLUSH
	CALL forwardfft(Nx,Ny,Nz,planfz,planfxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,temp1,temp2,vtemp1,vtemp2)

	enstr=0.5d0*REAL(abs(temp2(1,1,1)),kind(0d0))
	DO i=lowxv(mythreadid),upxv(mythreadid)
		DO j=1,Ny
			DO k=1,Nz
				temp2(k,j,i)=0.5d0*ky(j)*(vold(k,j,i)+v(k,j,i))
			END DO
		END DO
	END DO
	!$OMP FLUSH
	CALL backwardfft(Nx,Ny,Nz,planbz,planbxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,temp2,temp1,vtemp1,vtemp2)

	DO k=lowzv(mythreadid),upzv(mythreadid)
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=abs(temp1(i,j,k)*modescalereal)**2
			END DO
		END DO
	END DO
	!$OMP FLUSH

	CALL forwardfft(Nx,Ny,Nz,planfz,planfxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,temp1,temp2,vtemp1,vtemp2)

	enstr=enstr+0.5d0*REAL(abs(temp2(1,1,1)),kind(0d0))
	DO i=lowxv(mythreadid),upxv(mythreadid)
		DO j=1,Ny
			DO k=1,Nz
				temp2(k,j,i)=0.5d0*kz(k)*(vold(k,j,i)+v(k,j,i))
			END DO
		END DO
	END DO
	!$OMP FLUSH
	CALL backwardfft(Nx,Ny,Nz,planbz,planbxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,temp2,temp1,vtemp1,vtemp2)
	DO k=lowzv(mythreadid),upzv(mythreadid)
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=abs(temp1(i,j,k)*modescalereal)**2
			END DO
		END DO
	END DO
	!$OMP FLUSH
	CALL forwardfft(Nx,Ny,Nz,planfz,planfxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,temp1,temp2,vtemp1,vtemp2)

	enstr=enstr+0.5d0*REAL(abs(temp2(1,1,1)),kind(0d0))

	! .. Kinetic Energy ..
	DO k=lowzv(mythreadid),upzv(mythreadid)
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=( abs(u(i,j,k)-uold(i,j,k))/dt )**2
			END DO
		END DO
	END DO
	!$OMP FLUSH
	CALL forwardfft(Nx,Ny,Nz,planfz,planfxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,temp1,temp2,vtemp1,vtemp2)

	enkin=0.5d0*REAL(abs(temp2(1,1,1)),kind(0d0))

	! .. Potential Energy ..
	DO k=lowzv(mythreadid),upzv(mythreadid)
		DO j=1,Ny
			DO i=1,Nx
				temp1(i,j,k)=0.5d0*(abs((u(i,j,k)+uold(i,j,k))*0.50d0))**2&
					-0.125d0*Es*(abs(u(i,j,k))**4+abs(uold(i,j,k))**4)
			END DO
		END DO
	END DO
	!$OMP FLUSH
	CALL forwardfft(Nx,Ny,Nz,planfz,planfxy,mythreadid,numthreads,&
					lowxv,lowzv,upxv,upzv,temp1,temp2,vtemp1,vtemp2)

	enpot=REAL(abs(temp2(1,1,1)),kind(0d0))

	en=enpot+enkin+enstr

	END SUBROUTINE enercalc


CC=================================================================CC
CC                                                                 CC
CC  Subroutine IRSRFFT(X,M):                                       CC
CC      A inverse real-valued, in-place, split-radix FFT program   CC
CC      Decimation-in-frequency, cos/sin in second loop            CC
CC      and computed recursively                                   CC
CC      Symmetric input in order:                                  CC
CC              [ Re(0),Re(1),....,Re(N/2),Im(N/2-1),...Im(1)]     CC
CC      The output is real-valued                                  CC
CC                                                                 CC
CC  Input/output                                                   CC
CC      X    Array of input/output (length >= N)                   CC
CC      M    Transform length is N=2**M                            CC
CC                                                                 CC
CC  Calls:                                                         CC
CC      IRSTAGE, RBITREV                                           CC
CC                                                                 CC
CC  Author:                                                        CC
CC      H.V. Sorensen,   University of Pennsylvania,  Oct. 1985    CC
CC                       Arpa address: hvs@ee.upenn.edu            CC
CC  Modified:                                                      CC
CC      F. Bonzanigo,    ETH-Zurich,                  Sep. 1986    CC
CC      H.V. Sorensen,   University of Pennsylvania,  Mar. 1987    CC
CC                                                                 CC
CC  Reference:                                                     CC
CC      Sorensen, Jones, Heideman, Burrus :"Real-valued fast       CC
CC      Fourier transform algorithms", IEEE Tran. ASSP,            CC
CC      Vol. ASSP-35, No. 6, pp. 849-864, June 1987                CC
CC      Mitra&Kaiser: "Digital Signal Processing Handbook, Chap.   CC
CC      8, page 491-610, John Wiley&Sons, 1993                     CC
CC                                                                 CC
CC      This program may be used and distributed freely provided   CC
CC      this header is included and left intact                    CC
CC                                                                 CC
CC=================================================================CC
        SUBROUTINE IRSRFFT(X,M)
        REAL X(1)
C-------L shaped butterflies----------------------------------------C
        N = 2**M
        N2 = 2*N
        DO  10 K = 1, M-1
            N2 = N2/2
            N4 = N2/4
            CALL IRSTAGE(N,N2,N4,X(1),X(N4+1),X(2*N4+1),X(3*N4+1))
 10     CONTINUE
C-------Length two butterflies--------------------------------------C
        IS = 1
        ID = 4
 70         DO  60 I1 = IS,N,ID
                T1      = X(I1)
                X(I1)   = T1 + X(I1+1)
                X(I1+1) = T1 - X(I1+1)
 60         CONTINUE
            IS = 2*ID - 1
            ID = 4*ID
        IF (IS.LT.N) GOTO 70
C-------Digit reverse counter---------------------------------------C
        CALL RBITREV(X,M)
C-------Divide by N-------------------------------------------------C
        DO  99 I=1,N
            X(I) = X(I)/N
 99     CONTINUE
        RETURN
        END
CC=================================================================CC
CC                                                                 CC
CC  Subroutine IRSTAGE - the work-horse of the IRFFT               CC
CC       Computes a stage of an inverse real-valued split-radix    CC
CC       length N transform.                                       CC
CC  Author                                                         CC
CC       H.V. Sorensen,   University of Pennsylvania,  Mar. 1987   CC
CC                                                                 CC
CC      This program may be used and distributed freely provided   CC
CC      this header is included and left intact                    CC
CC                                                                 CC
CC=================================================================CC
        SUBROUTINE  IRSTAGE(N,N2,N4,X1,X2,X3,X4)
        DIMENSION X1(1),X2(1),X3(1),X4(1)
        N8 = N4/2
        IS = 0
        ID = 2*N2
 10         DO  20  I1 = IS+1,N,ID
                T1     = X1(I1) - X3(I1)
                X1(I1) = X1(I1) + X3(I1)
                X2(I1) = 2*X2(I1)
                T2     = 2*X4(I1)
                X4(I1) = T1 + T2
                X3(I1) = T1 - T2
 20         CONTINUE
            IS = 2*ID - N2
            ID = 4*ID
        IF (IS .LT. N) GOTO 10
C
        IF  (N4-1) 100,100,30
 30     IS = 0
        ID = 2*N2
 40         DO  50 I1 = IS+1+N8,N,ID
                T1    = (X2(I1) - X1(I1))*1.4142135623730950488
                T2    = (X4(I1) + X3(I1))*1.4142135623730950488
                X1(I1) = X1(I1) + X2(I1)
                X2(I1) = X4(I1) - X3(I1)
                X3(I1) = -T2-T1
                X4(I1) = -T2+T1
 50         CONTINUE
            IS = 2*ID - N2
            ID = 4*ID
        IF (IS .LT. N-1) GOTO 40
C
        IF  (N8-1) 100,100,60
 60     E  = 6.283185307179586/N2
        SS1 = SIN(E)
        SD1 = SS1
        SD3 = 3.*SD1-4.*SD1**3
        SS3 = SD3
        CC1 = COS(E)
        CD1 = CC1
        CD3 = 4.*CD1**3-3.*CD1
        CC3 = CD3
        DO  90  J = 2,N8
            IS = 0
            ID = 2*N2
            JN = N4 - 2*J + 2
 70             DO  80 I1=IS+J,N,ID
                    I2 = I1 + JN
                    T1     = X1(I1) - X2(I2)
                    X1(I1) = X1(I1) + X2(I2)
                    T2     = X1(I2) - X2(I1)
                    X1(I2) = X2(I1) + X1(I2)
                    T3     = X4(I2) + X3(I1)
                    X2(I2) = X4(I2) - X3(I1)
                    T4     = X4(I1) + X3(I2)
                    X2(I1) = X4(I1) - X3(I2)
                    T5 = T1 - T4
                    T1 = T1 + T4
                    T4 = T2 - T3
                    T2 = T2 + T3
                    X3(I1) =  T5*CC1 + T4*SS1
                    X3(I2) = -T4*CC1 + T5*SS1
                    X4(I1) =  T1*CC3 - T2*SS3
                    X4(I2) =  T2*CC3 + T1*SS3
 80             CONTINUE
                IS = 2*ID - N2
                ID = 4*ID
            IF (IS .LT. N) GOTO 70
C
            T1  = CC1*CD1 - SS1*SD1
            SS1 = CC1*SD1 + SS1*CD1
            CC1 = T1
            T3  = CC3*CD3 - SS3*SD3
            SS3 = CC3*SD3 + SS3*CD3
            CC3 = T3
 90     CONTINUE
 100    RETURN
        END
CC=================================================================CC
CC                                                                 CC
CC Subroutine RBITREV(X,M):                                        CC
CC      Bitreverses the array X of length 2**M. It generates a     CC
CC      table ITAB (minimum length is SQRT(2**M) if M is even      CC
CC      or SQRT(2*2**M) if M is odd). ITAB need only be generated  CC
CC      once for a given transform length.                         CC
CC                                                                 CC
CC Author:                                                         CC
CC      H.V. Sorensen,   University of Pennsylvania,  Aug. 1987    CC
CC                       Arpa address: hvs@ee.upenn.edu            CC
CC References:                                                     CC
CC      D. Evans, Tran. ASSP, Vol. ASSP-35, No. 8, pp 1120-1125    CC
CC      Aug. 1987                                                  CC
CC                                                                 CC
CC      This program may be used and distributed freely provided   CC
CC      this header is included and left intact                    CC
CC                                                                 CC
CC=================================================================CC
        SUBROUTINE RBITREV(X,M)
        DIMENSION X(1),ITAB(256)
C-------Initialization of ITAB array--------------------------------C
        M2 = M/2
        NBIT = 2**M2
        IF (2*M2.NE.M) M2 = M2 + 1
        ITAB(1) = 0
        ITAB(2) = 1
        IMAX = 1
        DO  10 LBSS = 2, M2
            IMAX = 2 * IMAX
            DO  10 I = 1, IMAX
                ITAB(I)      = 2 * ITAB(I)
                ITAB(I+IMAX) = 1 + ITAB(I)
 10     CONTINUE
C-------The actual bitreversal--------------------------------------C
        DO  20 K = 2, NBIT
            J0 = NBIT * ITAB(K) + 1
            I = K
            J = J0
            DO  20 L = 2, ITAB(K)+1
                T1   = X(I)
                X(I) = X(J)
                X(J) = T1
                I = I + NBIT
                J = J0 + ITAB(L)
 20     CONTINUE
        RETURN
        END


!*==dlaev2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAEV2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION   A, B, C, CS1, RT1, RT2, SN1
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
!>    [  A   B  ]
!>    [  B   C  ].
!> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
!> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
!> eigenvector for RT1, giving the decomposition
!>
!>    [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]
!>    [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] A
!> \verbatim
!>          A is DOUBLE PRECISION
!>          The (1,1) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is DOUBLE PRECISION
!>          The (1,2) element and the conjugate of the (2,1) element of
!>          the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is DOUBLE PRECISION
!>          The (2,2) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[out] RT1
!> \verbatim
!>          RT1 is DOUBLE PRECISION
!>          The eigenvalue of larger absolute value.
!> \endverbatim
!>
!> \param[out] RT2
!> \verbatim
!>          RT2 is DOUBLE PRECISION
!>          The eigenvalue of smaller absolute value.
!> \endverbatim
!>
!> \param[out] CS1
!> \verbatim
!>          CS1 is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[out] SN1
!> \verbatim
!>          SN1 is DOUBLE PRECISION
!>          The vector (CS1, SN1) is a unit right eigenvector for RT1.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  RT1 is accurate to a few ulps barring over/underflow.
!>
!>  RT2 may be inaccurate if there is massive cancellation in the
!>  determinant A*C-B*B; higher precision or correctly rounded or
!>  correctly truncated arithmetic would be needed to compute RT2
!>  accurately in all cases.
!>
!>  CS1 and SN1 are accurate to a few ulps barring over/underflow.
!>
!>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!>  Underflow is harmless if the input data is 0 or exceeds
!>     underflow_threshold / macheps.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DLAEV2(A,B,C,Rt1,Rt2,Cs1,Sn1)
      IMPLICIT NONE
!*--DLAEV2124
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION A , B , C , Cs1 , Rt1 , Rt2 , Sn1
!     ..
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.0D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.0D0)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
      DOUBLE PRECISION HALF
      PARAMETER (HALF=0.5D0)
!     ..
!     .. Local Scalars ..
      INTEGER sgn1 , sgn2
      DOUBLE PRECISION ab , acmn , acmx , acs , adf , cs , ct , df ,    &
     &                 rt , sm , tb , tn
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , SQRT
!     ..
!     .. Executable Statements ..
!
!     Compute the eigenvalues
!
      sm = A + C
      df = A - C
      adf = ABS(df)
      tb = B + B
      ab = ABS(tb)
      IF ( ABS(A)>ABS(C) ) THEN
         acmx = A
         acmn = C
      ELSE
         acmx = C
         acmn = A
      ENDIF
      IF ( adf>ab ) THEN
         rt = adf*SQRT(ONE+(ab/adf)**2)
      ELSEIF ( adf<ab ) THEN
         rt = ab*SQRT(ONE+(adf/ab)**2)
      ELSE
!
!        Includes case AB=ADF=0
!
         rt = ab*SQRT(TWO)
      ENDIF
      IF ( sm<ZERO ) THEN
         Rt1 = HALF*(sm-rt)
         sgn1 = -1
!
!        Order of execution important.
!        To get fully accurate smaller eigenvalue,
!        next line needs to be executed in higher precision.
!
         Rt2 = (acmx/Rt1)*acmn - (B/Rt1)*B
      ELSEIF ( sm>ZERO ) THEN
         Rt1 = HALF*(sm+rt)
         sgn1 = 1
!
!        Order of execution important.
!        To get fully accurate smaller eigenvalue,
!        next line needs to be executed in higher precision.
!
         Rt2 = (acmx/Rt1)*acmn - (B/Rt1)*B
      ELSE
!
!        Includes case RT1 = RT2 = 0
!
         Rt1 = HALF*rt
         Rt2 = -HALF*rt
         sgn1 = 1
      ENDIF
!
!     Compute the eigenvector
!
      IF ( df>=ZERO ) THEN
         cs = df + rt
         sgn2 = 1
      ELSE
         cs = df - rt
         sgn2 = -1
      ENDIF
      acs = ABS(cs)
      IF ( acs>ab ) THEN
         ct = -tb/cs
         Sn1 = ONE/SQRT(ONE+ct*ct)
         Cs1 = ct*Sn1
      ELSEIF ( ab==ZERO ) THEN
         Cs1 = ONE
         Sn1 = ZERO
      ELSE
         tn = -cs/tb
         Cs1 = ONE/SQRT(ONE+tn*tn)
         Sn1 = tn*Cs1
      ENDIF
      IF ( sgn1==sgn2 ) THEN
         tn = Cs1
         Cs1 = -Sn1
         Sn1 = tn
      ENDIF
!
!     End of DLAEV2
!
      END SUBROUTINE DLAEV2


      double precision function nearfloat(x, dir)
*
*     PURPOSE
*        Compute the near (double) float from x in
*        the direction dir
*        dir >= 0 => toward +oo
*        dir < 0  => toward -oo
*
*     REMARK
*        This code may be shorter if we assume that the
*        radix base of floating point numbers is 2 : one
*        could use the frexp C function to extract the
*        mantissa and exponent part in place of dealing
*        with a call to the log function with corrections
*        to avoid possible floating point error...
*
      implicit none

*     PARAMETERS
      double precision x, dir

*     EXTERNAL FUNCTIONS
      double precision dlamch
      external         dlamch
      integer          isanan
      external         isanan
*     LOCAL VARIABLES

      double precision sign_x, ep, xa, d, m

      integer          e, i, p

*     STATIC VARIABLES

      logical          first, DENORM

      double precision RMAX, RMIN, ULP, BASE, LNB, TINY
      save             RMAX, RMIN, ULP, BASE, LNB, TINY
      save             first, DENORM
      data             first /.true./

*     TEXT
*     got f.p. parameters used by the algorithm
      if (first) then
          RMAX = dlamch('o')
          RMIN = dlamch('u')
          BASE = dlamch('b')
          p    = int(dlamch('n'))
          LNB  = log(BASE)

*         computation of 1 ulp : 1 ulp = base^(1-p)
*         p = number of digits for the mantissa = dlamch('n')
          ULP  = BASE**(1 - p)

*         query if denormalised numbers are used : if yes
*         compute TINY the smallest denormalised number > 0 :
*         TINY is also the increment between 2 neighbooring
*         denormalised numbers
          if (RMIN/BASE .ne. 0.d0) then
             DENORM = .true.
             TINY = RMIN
             do i = 1, p-1
                TINY = TINY / BASE
             enddo
          else
             DENORM = .false.
          endif
          first = .false.
      endif

      d = sign(1.d0, dir)
      sign_x = sign(1.d0, x)
      xa = abs(x)

      if (isanan(x) .eq. 1) then
*     nan
         nearfloat = x

      elseif (xa .gt. RMAX) then
*     +-inf
         if (d*sign_x .lt. 0.d0) then
            nearfloat = sign_x * RMAX
         else
            nearfloat = x
         endif

      elseif (xa .ge. RMIN) then
*     usual case : x is a normalised floating point number
*        1/ got the exponent e and the exponent part ep = base^e
         e = int( log(xa)/LNB )
         ep = BASE**e
*        in case of xa very near RMAX an error in e (of + 1)
*        result in an overflow in ep
         if ( ep .gt. RMAX ) then
            e = e - 1
            ep = BASE**e
         endif
*        also in case of xa very near RMIN and when denormalised
*        number are not used, an error in e (of -1) results in a
*        flush to 0 for ep.
         if ( ep .eq. 0.d0 ) then
            e = e + 1
            ep = BASE**e
         endif

*        2/ got the mantissa
         m = xa/ep

*        3/ verify that 1 <= m < BASE
         if ( m .lt. 1.d0 ) then
*           multiply m by BASE
            do while ( m .lt. 1.d0 )
               m = m * BASE
               ep = ep / BASE
            enddo
         elseif ( m .ge. BASE ) then
*           divide m by BASE
            do while ( m .ge. 1.d0 )
               m = m / BASE
               ep = ep * BASE
            enddo
         endif

*        4/ now compute the near float
         if (d*sign_x .lt. 0.d0) then
*           retrieve one ULP to m but there is a special case
            if ( m .eq. 1.d0 ) then
*              this is the special case : we must retrieve ULP / BASE
               nearfloat = sign_x*( m - (ULP/BASE) )*ep
            else
               nearfloat = sign_x*( m - ULP )*ep
            endif
         else
            nearfloat = sign_x*(m + ULP)*ep
         endif

      elseif ( x .eq. 0.d0 ) then
*     case x = 0  nearfloat depends if denormalised numbers are used
         if (DENORM) then
            nearfloat = d*TINY
         else
            nearfloat = d*RMIN
         endif

      else
*     x is a denormalised number
         nearfloat = x + d*TINY

      endif

      end


      subroutine orthoapproxmatmonic(nsuccess)

      implicit real *8 (a-h,o-z)
      real *8 uvs(2,10000),wts(10000)
      real *8, allocatable :: x(:),y(:),w(:),basis_jk(:),basiskl(:)
      real *8, allocatable :: a_diag(:),vals2coefs(:,:)
      real *8, allocatable :: coefs2coefs(:,:)
      real *8, allocatable :: o_basis(:,:),p_coefs(:,:)
      real *8 nrm_kl ! numerator
      integer aorder,idx_jk,idx_jk_new
      integer add_power(2),power_x_new,power_y_new
      integer, allocatable :: o_basis_tile(:,:), tile_to_idx(:)
      integer, allocatable :: power_x(:), power_y(:)
      integer, allocatable :: xpower(:), ypower(:)

      nsuccess = 1

      aorder = 8
      norder = 8
      npols = (norder+1)*(norder+2)/2

      allocate(x(npols),y(npols),w(npols),basis_jk(npols))
      allocate(o_basis(aorder*(aorder+1)/2,npols))
      allocate(p_coefs(aorder*(aorder+1)/2,aorder*(aorder+1)/2))
      allocate(o_basis_tile(aorder,aorder))
      allocate(tile_to_idx(aorder*(aorder+1)/2))
      allocate(a_diag(aorder*(aorder+1)/2))
      allocate(vals2coefs(aorder*(aorder+1)/2,npols))
      allocate(coefs2coefs(aorder*(aorder+1)/2,aorder*(aorder+1)/2))
      allocate(power_x(aorder**2),power_y(aorder**2))
      allocate(xpower(aorder*(aorder+1)/2),ypower(aorder*(aorder+1)/2))

      call get_vioreanu_nodes(norder,npols,uvs)
      call get_vioreanu_wts(norder,npols,wts)
      x = uvs(1,1:npols)
      y = uvs(2,1:npols)
      w = wts(1:npols)
      o_basis = 1.0
      p_coefs = 0.0
      do i = 1,aorder*(aorder+1)/2
          p_coefs(i,i) = 1.0
      end do
      o_basis_tile(1,1) = 1
      tile_to_idx(1) = 1
      do j = 2,aorder
          do k = 1,j
              if (k .lt. j) then
                  basis_jk = x*o_basis(j*(j-1)/2+k-j+1,:)
              else
                  basis_jk = y*o_basis(j*(j-1)/2,:)
              end if
              o_basis(j*(j-1)/2+k,:) = basis_jk
              o_basis_tile(k,j-k+1) = j*(j-1)/2+k;
              tile_to_idx(j*(j-1)/2+k) = (j-k)*aorder+k;
          end do
          do k = j*(j-1)/2+1,j*(j+1)/2
              do l = 1,k-1
                  nrm_kl = sum(o_basis(k,:)*o_basis(l,:)*w)
                  p_coefs(l,k) = -nrm_kl/sum(o_basis(l,:)**2.*w)
              end do
              basiskl = matmul(transpose(o_basis(1:k,:)),p_coefs(1:k,k))
              o_basis(k,:) = basiskl
          end do
      end do

      a_diag = matmul(o_basis**2,w)
      do i = 1,aorder*(aorder+1)/2
        vals2coefs(i,:) = o_basis(i,:)*w/a_diag(i)
      end do

      coefs2coefs = 0.0
      do i = 1,aorder*(aorder+1)/2
          coefs2coefs(i,i) = 1.0
      end do
      power_x=reshape(spread((/(i,i=0,aorder-1)/),1,aorder),[aorder**2])
      power_y=reshape(spread((/(i,i=0,aorder-1)/),2,aorder),[aorder**2])
      do j = 1,aorder
          do k = j*(j-1)/2+1,j*(j+1)/2
              if (k .lt. j*(j+1)/2) then
                  idx_jk = k-j+1
                  add_power = (/1,0/)
              else
                  idx_jk = k-j
                  add_power = (/0,1/)
              end if
              do l = 1,idx_jk
                  power_x_new = power_x(tile_to_idx(l))+add_power(1)
                  power_y_new = power_y(tile_to_idx(l))+add_power(2)
                  idx_jk_new = o_basis_tile(power_y_new+1,power_x_new+1)
                  coefs2coefs(idx_jk_new,k) = coefs2coefs(l,idx_jk)
              end do
          coefs2coefs(1:k,k)=matmul(coefs2coefs(1:k,1:k),p_coefs(1:k,k))
          end do
      end do

      ! eval
      xpower = power_x(tile_to_idx); ypower = power_y(tile_to_idx);

      !
      open(2, file = '../orthomat.txt')
      do i = 1,aorder*(aorder+1)/2
          write(2,*) coefs2coefs(i,:)
      end do
      close(2)

      end


c     Program DRDPOLZ
c>> 2009-10-28 DRZPOLZ Krogh Mods to get comples used in single prec.
c>> 1996-07-09 DRZPOLZ Krogh Set for deriving single precision C vers.
c>> 1994-08-09 DRDPOLZ WVS Remove '0' in format
c>> 1992-03-06 DRDPOLZ CLL
c>> 1987-12-09 DRDPOLZ  Lawson  Initial Code.
c Conversion should only be done from "D" to "S" for processing to C.
c--D replaces "?": DR?POLZ, ?POLZ
c     Demonstration driver for DPOLZ.
c     ------------------------------------------------------------------
      double precision A1(4), A2(6), H(25)

c++ CODE for .D. | .C. is active
      double precision Z1(2,3), Z2(2,5)
c++ CODE for .S. & ~.C. is inactive
c      complex       Z1(3), Z2(5)
c++ END
      integer N1, N2, IERR
c++ CODE for ~.C. is active
      integer I, k
c++ CODE for .C. is inactive
c%%    long int i, k;
c++ END
c
      data A1 / 1.D0, -4.D0, 1.D0, -4.D0 /
      data A2 / 1.D0, -15.D0, 85.D0, -225.D0, 274.D0, -120.D0 /
c     ------------------------------------------------------------------
      N1 = 3
      N2 = 5
c
c++ CODE for ~.C. is active
  100 format(' ','Degree =',I2/' ', 'Coefficients =',(T20,4(F10.4,1X)))
  200 format(' ','Roots ='/(2(1X,'(',1X,F8.5,',',1X,F8.5,2X,')':2X)))
  300 format(//' ')
      print 100, N1, (A1(I),I=1,4)
c++ CODE for .C. is inactive
c%%   printf( " Degree =%2ld\n Coefficients =      ", n1 );
c%%   for (i = 0; i < 4; i++) printf( "%10.4f", a1[i] );
c++ End
      call DPOLZ(A1,N1,Z1,H,IERR)
c++ CODE for .D. & ~.C. is active
      print 200, ((Z1(K,I),K=1,2),I=1,3)
c++ CODE for .S. & ~.C. is inactive
c      print 200, (Z1(I),I=1,3)
c++ CODE for ~.C. is active
      print 300
      print 100, N2, (A2(I),I=1,6)
c++ CODE for .C. is inactive
c%%   printf( "\n Roots =\n" );
c%%   for (i = 0; i < 3; i+=2) {
c%%      printf( " ( %8.5f, %8.5f  )", z1[i][0],z1[i][1] );
c%%      if (i<2) printf( " ( %8.5f, %8.5f  )", z1[i+1][0],z1[i+1][1] );
c%%      printf( "\n" );}
c%%   printf( "\n\n \n Degree =%2ld\n Coefficients =      ", n2 );
c%%   for (i = 0; i < 6; i+=4) {
c%%      for (k = i ; k < (i < 2 ? i + 4 : 6); k++)
c%%         printf( "%10.4f", a2[k] );
c%%         if (i < 4) printf( "\n                     " );}
c++ End
      call DPOLZ(A2,N2,Z2,H,IERR)
c++ CODE for .D. & ~.C. is active
      print 200,((Z2(K,I),K=1,2),I=1,5)
c++ CODE for .S. & ~.C. is inactive
c      print 200,(Z2(I),I=1,5)
c++ CODE for .C. is inactive
c%%   printf( "\n Roots =\n" );
c%%   for (i = 0; i < 5; i+=2) {
c%%       printf( " ( %8.5f, %8.5f  )", z2[i][0],z2[i][1] );
c%%       if (i<4) printf(" ( %8.5f, %8.5f  )", z2[i+1][0],z2[i+1][1]);
c%%       printf( "\n" );}
c%%   printf( "\n" );
c++ END
      end


!==============================================================================!
  real function Turbulent_Prandtl_Number(grid, c)
!------------------------------------------------------------------------------!
!   Computes turbulent Prandtl number according to Kays, W. M. and             !
!   Crawford, M. E., Convective Heat and Mass Transfer,                        !
!   3rd edn. McGraw-Hill, New York, 1993.                                      !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod,      only: TINY
  use Grid_Mod,       only: Grid_Type
  use Flow_Mod,       only: viscosity, conductivity, capacity
  use Turbulence_Mod, only: vis_t
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  integer         :: c
  real            :: pr, pr_t_inf, pe_t
!==============================================================================!

  pr = viscosity * capacity / conductivity
  pr_t_inf = 0.85
  pe_t     = max(pr * vis_t(c) / viscosity, TINY)

  Turbulent_Prandtl_Number =                                            &
    1.0 / (   1.0/(2.0*pr_t_inf)                                        &
           +  0.3*pe_t * sqrt(1.0/pr_t_inf)                             &
           - (0.3*pe_t)**2 * (1.0-exp(-1.0/(0.3*pe_t*sqrt(pr_t_inf))))  &
          )

  end function


!!**.****|****.****|****.****|****.****|****.****|****.****|****.****|****.****|
!! * synchrotron.f *                               galprop package * 4/14/2000
!!**"****!****"****!****"****!****"****!****"****!****"****!****"****!****"****|

          real*8 function SYNCHROTRON(gamma,Esynch,B)
c**********************************************************************
c         *** I.Moskalenko (MPE,Garching) *** version of 12.11.1997 ***
c PURPOSE:
c Calculates the synchrotron emissivity of an electron integrated
c over the emission angle for an isotropic pitch angle distribution.
c UNITS: erg/s/Hz;
c        for units MeV/s/Hz remove a comment "c[0]";
c        for transformation to units 1/MeV/s remove comments "c[0]","c[2]".
c REFERENCES:
c [1] Ginzburg 1979 ,"Theor. Phys. & Astrophys."
c [2] Ghisellini, Guilbert, Svensson 1988, ApJ 334, L5 (eq.[9])
c [3] Strong A.W., Moskalenko I.V., Reimer O. 2000, ApJ 537, 763
c INPUT parameters:
c    gamma   is the electron Lorentz factor;
c    Esynch (Hz)   is the frequency of synchrotron photons;
c       if you prefer that Esynch to be the energy (MeV) of synchro-photons,
c       then remove a comment "c[1]";
c    B (gauss=g^1/2 cm^-1/2 s^-1)   is the (total) magnetic field strength.
c**********************************************************************
      implicit real*8 (a-h,m-z)
      Pi = 3.14159265d0
      MeV_to_erg = 1.60217733d-6
      h  = 6.6260755d-27 /MeV_to_erg                ! MeV*s; Planck constant
      emc = 4.80321d-10/9.10939d-28/2.99792d10      ! (cm/g)^1/2; emc =e/mc
      e2c = 2.81794d-13*0.511*MeV_to_erg/2.99792d10 ! erg*s; =e^2/c =r0*mc^2/c
c[0]      e2c = 2.81794d-13*0.511/2.99792d10   ! MeV*s; =e^2/c= r0*mc^2/c
      nuB = emc*B/2.d0/Pi                           ! Hz; frequency

      x=Esynch/nuB/gamma**2/3.d0           ! if [Esynch] = Hz
c[1]      x=(Esynch/h)/nuB/gamma**2/3.d0       ! if [Esynch] = MeV
      BSK1 = BSKR3(x,1)                    ! Bessel K{1/3}
      BSK4 = BSKR3(x,-2)+2.d0/3.d0/x*BSK1  ! Bessel K{4/3}
      SYNCHROTRON=x*x*(BSK4*BSK1-3.d0/5.d0*x*(BSK4+BSK1)*(BSK4-BSK1))
     2   *4.d0*Pi*dsqrt(3.d0)*e2c*nuB  !<- units erg/s/Hz (or MeV/s/Hz if [0])
c[2]     3   /Esynch/h                     !<- transformation to units 1/MeV/s
      return
      end

      real*8 FUNCTION BSIKR3(X,NU)
c**********************************************************************
c Entries BSIR3(X,NU) and BSKR3 calculate the modified Bessel functions
c   I{nu/3}(X) and K{nu/3}(X) for real arguments X>0 and NU=-2,-1,1,2.
c Entries EBSIR3(X,NU) and EBSKR3 calculate exp(-X)*I{nu/3}(X) and
c   exp(X)*K{nu/3}(X), correspondingly.
c The value x=0 is permitted for the functions I if NU>0.
c The functions K are even with respect to NU.       ** CERNLIB C340 **
c**********************************************************************
      implicit real*8 (a-h,o-z)
      LOGICAL L,E,NUL,NOE

      ENTRY EBSIR3(X,NU)

      E=.TRUE.
      GO TO 7

      ENTRY BSIR3(X,NU)

      E=.FALSE.
    7 L=.TRUE.
      N=IABS(NU)
      IF(N .NE. 1 .AND. N .NE. 2) GO TO 10
      IF(X .LE. 0.0d0) GO TO 11
      NUL=NU .LT. 0
      IF(X .GT. 8.0d0) GO TO 1
      IF(NUL) N=N+2
    6 Y=0.0625d0*X**2-2.0d0

      GO TO (21,22,23,24), N

   21 A=        0.00000 00000 00001d0
      B=Y*A  +  0.00000 00000 00038d0
      A=Y*B-A+  0.00000 00000 01998d0
      B=Y*A-B+  0.00000 00000 90184d0
      A=Y*B-A+  0.00000 00034 97936d0
      B=Y*A-B+  0.00000 01152 07185d0
      A=Y*B-A+  0.00000 31776 13643d0
      B=Y*A-B+  0.00007 22075 54088d0
      A=Y*B-A+  0.00132 57975 71063d0
      B=Y*A-B+  0.01921 26868 62831d0
      A=Y*B-A+  0.21351 04236 00374d0
      B=Y*A-B+  1.75552 58978 34804d0
      A=Y*B-A+ 10.20622 18597 97179d0
      B=Y*A-B+ 39.59331 03435 21063d0
      A=Y*B-A+ 95.23190 27040 92164d0
      A=Y*A-B+130.34733 09768 33054d0
      BSIKR3=0.5d0*(A-B)*X**0.333333333333333d0
      GO TO 25

   22 B=       0.00000 00000 00012d0
      A=Y*B  + 0.00000 00000 00650d0
      B=Y*A-B+ 0.00000 00000 30014d0
      A=Y*B-A+ 0.00000 00011 92919d0
      B=Y*A-B+ 0.00000 00403 31192d0
      A=Y*B-A+ 0.00000 11441 45898d0
      B=Y*A-B+ 0.00002 68011 17197d0
      A=Y*B-A+ 0.00050 85533 07618d0
      B=Y*A-B+ 0.00763 78220 14940d0
      A=Y*B-A+ 0.08824 17620 77464d0
      B=Y*A-B+ 0.75671 34574 71448d0
      A=Y*B-A+ 4.60121 27076 45103d0
      B=Y*A-B+18.68656 02563 49831d0
      A=Y*B-A+46.83793 90742 83087d0
      A=Y*A-B+65.54958 48060 70052d0
      BSIKR3=0.5d0*(A-B)*X**0.666666666666666d0
      GO TO 25

   23 A=        0.00000 00000 00007d0
      B=Y*A  +  0.00000 00000 00371d0
      A=Y*B-A+  0.00000 00000 18463d0
      B=Y*A-B+  0.00000 00007 94846d0
      A=Y*B-A+  0.00000 00293 09948d0
      B=Y*A-B+  0.00000 09143 62383d0
      A=Y*B-A+  0.00002 37873 65337d0
      B=Y*A-B+  0.00050 74091 61720d0
      A=Y*B-A+  0.00869 83095 97421d0
      B=Y*A-B+  0.11697 76116 93127d0
      A=Y*B-A+  1.19852 10167 30412d0
      B=Y*A-B+  9.02594 18911 35279d0
      A=Y*B-A+ 47.81292 47970 09021d0
      B=Y*A-B+168.94690 54665 51934d0
      A=Y*B-A+374.90419 63977 61772d0
      A=Y*A-B+493.52893 55220 53900d0
      BSIKR3=0.5d0*(A-B)/X**0.333333333333333d0
      GO TO 25

   24 A=        0.00000 00000 00020d0
      B=Y*A  +  0.00000 00000 01141d0
      A=Y*B-A+  0.00000 00000 55474d0
      B=Y*A-B+  0.00000 00023 30625d0
      A=Y*B-A+  0.00000 00837 21455d0
      B=Y*A-B+  0.00000 25392 92566d0
      A=Y*B-A+  0.00006 40820 86137d0
      B=Y*A-B+  0.00132 26199 57421d0
      A=Y*B-A+  0.02187 48334 95706d0
      B=Y*A-B+  0.28291 28347 05747d0
      A=Y*B-A+  2.77810 11375 55156d0
      B=Y*A-B+ 19.98542 28723 93609d0
      A=Y*B-A+100.90075 85218 30026d0
      B=Y*A-B+340.10272 33771 79942d0
      A=Y*B-A+726.03216 50664 95924d0
      A=Y*A-B+939.90625 59898 40844d0
      BSIKR3=0.5d0*(A-B)/X**0.666666666666666d0

   25 IF(L .AND. E) BSIKR3=dEXP(-X)*BSIKR3
      IF(L) RETURN

      IF(N .GT. 2) GO TO 2
      F=BSIKR3
      N=N+2
      GO TO (21,22,23,24), N
    2 BSIKR3=1.813799364234218d0*(BSIKR3-F)
      IF(E) BSIKR3=dEXP(X)*BSIKR3
      RETURN

    1 Y=32.0d0/X-2.0d0

      GO TO (31,32), N

   31 B=     -0.00000 00000 00002d0*Y
      A=Y*B  +0.00000 00000 00014d0
      B=Y*A-B+0.00000 00000 00016d0
      A=Y*B-A-0.00000 00000 00091d0
      B=Y*A-B-0.00000 00000 00265d0
      A=Y*B-A+0.00000 00000 00298d0
      B=Y*A-B+0.00000 00000 03074d0
      A=Y*B-A+0.00000 00000 05374d0
      B=Y*A-B-0.00000 00000 14443d0
      A=Y*B-A-0.00000 00001 16415d0
      B=Y*A-B-0.00000 00003 75617d0
      A=Y*B-A-0.00000 00006 11915d0
      B=Y*A-B+0.00000 00012 91332d0
      A=Y*B-A+0.00000 00227 82111d0
      B=Y*A-B+0.00000 02520 73238d0
      A=Y*B-A+0.00000 37262 16111d0
      B=Y*A-B+0.00009 08034 04815d0
      A=Y*B-A+0.00467 34791 99874d0
      A=Y*A-B+2.00917 23421 86414d0
      GO TO 33

   32 B=      0.00000 00000 00001d0
      A=Y*B  -0.00000 00000 00001d0
      B=Y*A-B-0.00000 00000 00005d0
      A=Y*B-A+0.00000 00000 00005d0
      B=Y*A-B+0.00000 00000 00040d0
      A=Y*B-A+0.00000 00000 00012d0
      B=Y*A-B-0.00000 00000 00312d0
      A=Y*B-A-0.00000 00000 00677d0
      B=Y*A-B+0.00000 00000 01331d0
      A=Y*B-A+0.00000 00000 10138d0
      B=Y*A-B+0.00000 00000 19007d0
      A=Y*B-A-0.00000 00000 39372d0
      B=Y*A-B-0.00000 00004 20439d0
      A=Y*B-A-0.00000 00019 23009d0
      B=Y*A-B-0.00000 00075 81590d0
      A=Y*B-A-0.00000 00365 71574d0
      B=Y*A-B-0.00000 02916 95418d0
      A=Y*B-A-0.00000 41406 57716d0
      B=Y*A-B-0.00010 60188 22352d0
      A=Y*B-A-0.00646 71526 00616d0
      A=Y*A-B+1.98726 99734 33850d0

   33 BSIKR3=0.199471140200717d0*(A-B)/dSQRT(X)
      NOE=.NOT. E
      IF(NUL .OR. NOE) V=dEXP(-X)
      IF(NUL) GO TO 5
      IF(NOE) BSIKR3=BSIKR3/V
      RETURN

    5 Y=20.0d0/X-2.0d0

      GO TO (41,42), N

   41 A=     -0.00000 00000 00001d0
      B=Y*A  +0.00000 00000 00006d0
      A=Y*B-A-0.00000 00000 00040d0
      B=Y*A-B+0.00000 00000 00295d0
      A=Y*B-A-0.00000 00000 02327d0
      B=Y*A-B+0.00000 00000 19868d0
      A=Y*B-A-0.00000 00001 85898d0
      B=Y*A-B+0.00000 00019 39555d0
      A=Y*B-A-0.00000 00231 23232d0
      B=Y*A-B+0.00000 03265 50333d0
      A=Y*B-A-0.00000 57870 60592d0
      B=Y*A-B+0.00014 30095 80961d0
      A=Y*B-A-0.00631 44392 60799d0
      A=Y*A-B+1.98707 28245 52186d0
      GO TO 43

   42 A=      0.00000 00000 00001d0
      B=Y*A  -0.00000 00000 00006d0
      A=Y*B-A+0.00000 00000 00042d0
      B=Y*A-B-0.00000 00000 00308d0
      A=Y*B-A+0.00000 00000 02441d0
      B=Y*A-B-0.00000 00000 20946d0
      A=Y*B-A+0.00000 00001 97224d0
      B=Y*A-B-0.00000 00020 74924d0
      A=Y*B-A+0.00000 00250 24412d0
      B=Y*A-B-0.00000 03595 19190d0
      A=Y*B-A+0.00000 65547 92550d0
      B=Y*A-B-0.00017 13895 98262d0
      A=Y*B-A+0.00897 12068 42484d0
      A=Y*A-B+2.01829 90761 45578d0

   43 F=(A-B)/dSQRT(X)
      IF(L) GO TO 4
      BSIKR3=0.626657068657750d0*F
      IF(E) RETURN
      BSIKR3=dEXP(-X)*BSIKR3
      RETURN

    4 BSIKR3=BSIKR3+0.345494149471336d0*F*V**2
      IF(E) RETURN
      BSIKR3=BSIKR3/V
      RETURN

      ENTRY EBSKR3(X,NU)

      E=.TRUE.
      GO TO 8

      ENTRY BSKR3(X,NU)

      E=.FALSE.
    8 L=.FALSE.
      N=IABS(NU)
      IF(N .NE. 1 .AND. N .NE. 2) GO TO 10
      IF(X .LE. 0.0d0) GO TO 11
      IF(X .GE. 5.0d0) GO TO 5
      GO TO 6

   10 BSIKR3=0.d0
      PRINT 12,NU
      RETURN
   11 BSIKR3=0.d0
      IF(.NOT. L) GO TO 9
      IF(NU .GT. 0 .AND. X .EQ. 0.0) RETURN
    9 PRINT 13,X
      RETURN
   12 FORMAT(1X,30HBSIKR3 ... ILLEGAL VALUE NU = ,I15)
   13 FORMAT(1X,24HBSIKR3 ... NEGATIVE X = ,E15.4)

      END


program max_array
    implicit none
    integer, dimension(3, 4) :: A
    integer :: i, j
    character(len=10), parameter :: FMT = '(A, 4I13)'

    A = reshape( [ (((i - 1)*size(A, 2) + j, j=1,size(A, 2)), i=1,size(A, 1)) ], &
                shape(A)) - 8
    do i = 1, size(A, 1)
        print *, A(i, :)
    end do
    print FMT, 'maximum = ', maxval(A)
    print FMT, 'column maximum = ', maxval(A, dim=1)
    print FMT, 'row maximum = ', maxval(A, dim=2)
    print FMT, 'maximum odd elment = ', maxval(A, mask=mod(A, 2) /= 0)
    print FMT, 'row maximum negative elment = ', maxval(A, dim=1, mask=A < 0)
    print FMT, 'maxloc = ', maxloc(A)
    print FMT, 'column maxloc = ', maxloc(A, dim=1)
end program max_array


      program main

c*********************************************************************72
c
cc MAIN is the main program for hbm_mtu1.
c
c  Discussion:
c
c    Calls MTU1 or MTU2 over the filename passed as the second command
c    line arg (the first argument is 1 or 2, to specify if MTU1 or MTU2
c    is to be called).
c
c  Licensing:
c
c    Public Domain. Unlicense.
c
c  Modified:
c
c    Mon, 11 Jul 2016 01:41:23 -0300
c
c  Author:
c
c    Henrique Becker
c
      use iso_fortran_env
      implicit none

      integer(int64) :: n    ! Quantity of items on the read instance.
      integer(int64) :: c    ! Capacity of the read instance.

      integer(int64), allocatable :: p(:) ! Instance item profits.
      integer(int64), allocatable :: w(:) ! Instance item weights.
      integer(int64), allocatable :: x(:) ! # of each item on solution.

      integer(int64) :: z     ! Solution optimal value.
      integer(int64) :: y_opt ! Weight of the found optimal solution.

      integer(int64) :: jdim ! Size of MTU arrays, must be at least n+1.
      integer :: jck  ! Boolean. The instance should be checked?
      integer :: jfo  ! Boolean. Return exact result?
      integer(int64) :: jub  ! Output. Upper bound.

      ! Five arrays used internally by MTU2.
      real(real64), allocatable :: xo(:)
      real(real64), allocatable :: rr(:)
      integer(int64), allocatable :: po(:)
      integer(int64), allocatable :: wo(:)
      integer(int64), allocatable :: pp(:)

      ! Variables needed to read the time used
      integer      :: t1, t2, clock_rate, clock_max, max_sec
      real(real64) :: ttime

      ! Variables used to parse the command-line
      character(len=255) :: mtu_version
      character(len=255) :: fname
      integer :: argc

      ! Auxiliar variables loop variables used inside main
      integer(int64) :: j
      integer(int64) :: i
      integer(int64) :: jpx
      integer(int64) :: kf

      argc = command_argument_count()
      if (argc .ne. 2) then
        write (*,*) 'usage: <binary_path> <1 or 2> <instance_filename>'
        write (*,*) 'The first parameter define if MTU1 or MTU2 will be
     *used. The second is a path to an instance in the .sukp format.'
        write (*,*) 'Number of parameters received: ', argc
        write (*,*) 'Aborting.'
        stop
      end if
      call get_command_argument(1, mtu_version)
      call get_command_argument(2, fname)

      call read_sukp_instance(fname, n, c, w, p)
      jdim = n + 1

      jfo = 1 ! We want an exact solution.
      jck = 1 ! We don't want input checking (to not mess the times).

      call system_clock (t1, clock_rate, clock_max)

      allocate( x(jdim) )
      allocate( xo(jdim) )
      allocate( rr(jdim) )
      allocate( po(jdim) )
      allocate( wo(jdim) )
      allocate( pp(jdim) )

      if (mtu_version .EQ. '1') then
        z = 0
        do j=1,n
          rr(j) = real(p(j), real64)/real(w(j), real64)
        end do
        do j=1,n
          pp(j) = j
        end do
        ! Unhappily, because the casting below, this means the program
        ! don't work with a number of items bigger than an int32.
        call sortr(n,rr,pp,jdim)
        do j=1,n
          i = pp(j)
          po(j) = p(i)
          wo(j) = w(i)
        end do
        call mtu1(n,po,wo,c,0._real64,z,xo,jdim,jub,x,rr)
        do j=1,n
          x(j) = 0
        end do
        do j=1,n
          i = pp(j)
          x(i) = xo(j)
        end do
      else if (mtu_version .EQ. '2') then
        call mtu2 (n,p,w,c,z,x,jdim,jfo,jck,jub,po,wo,xo,rr,pp)
      else
        write (*,*) 'The first parameter define if MTU1 or MTU2 will be
     *used, it has to be 1 or 2.'
        write (*,*) 'Value of first argument: ', mtu_version
        write (*,*) 'Aborting.'
        stop
      end if

      call system_clock (t2, clock_rate, clock_max)
      ttime = real(t2 - t1)/real(clock_rate)
      max_sec = clock_max/clock_rate

      write (*,'(a,i0)') 'opt: ', z
      write (*,'(a,i0)') 'y_opt: ', y_opt

      y_opt = 0
      do i = 1, n
        if ( x(i) .ge. 1 ) then
          y_opt = y_opt + w(i)*x(i)
          write (*, '(a,i0,a,i0,a,i0,a,i0,a,f19.9)') 'ix: ', i,
     *' qt: ', x(i), ' w: ', w(i), ' p: ', p(i), ' e: ',
     *real(p(i), real64)/real(w(i), real64)
        end if
      end do

      write (*,'(a,i0)') 'c: ', c
      write (*,'(a,i0)') 'n: ', n
      write (*,'(a,f19.9)') 'Seconds: ', ttime
      write (*,'(a,i0)') 'Max number of seconds before wrap: ', max_sec
      stop
      contains

      subroutine read_sukp_instance(fname, n, c, w, p)
c*********************************************************************72
c
cc read_sukp_instance Takes filename and reads a sUKP instance from it.
c
c  Licensing:
c
c    Public Domain. Unlicense.
c
c  Modified:
c
c    Mon, 11 Jul 2016 01:41:23 -0300
c
c  Author:
c
c    Henrique Becker
c
c  Parameters:
c
c    fname Input, Name of the file with an sUKP instance.
c    n Output, Size of the instance
c    c Output, Knapsack capacity of the instance
c    w Output, item weights
c    p Output, item profits
c
      implicit none

      character(len=*) :: fname
      integer(int64) :: n
      integer(int64) :: c
      integer(int64), allocatable :: w(:)
      integer(int64), allocatable :: p(:)
      integer(int64) :: tmp1, tmp2, i

      open(1,file=fname)
      read(1,*) n
      read(1,*) c
      allocate( w(n) )
      allocate( p(n) )
      do i=1,n
        read (1,*) tmp1,tmp2
        w(i) = tmp1
        p(i) = tmp2
      end do
      close(1)

      return
      end
      end program

      SUBROUTINE MTU2(N,P,W,C,Z,X,JDIM,JFO,JCK,JUB,PO,WO,XO,RR,PP)
C
C THIS SUBROUTINE SOLVES THE UNBOUNDED SINGLE KNAPSACK PROBLEM
C
C MAXIMIZE  Z = P(1)*X(1) + ... + P(N)*X(N)
C
C SUBJECT TO:   W(1)*X(1) + ... + W(N)*X(N) .LE. C ,
C               X(J) .GE. 0 AND INTEGER  FOR J=1,...,N.
C
C THE PROGRAM IS INCLUDED IN THE VOLUME
C   S. MARTELLO, P. TOTH, "KNAPSACK PROBLEMS: ALGORITHMS
C   AND COMPUTER IMPLEMENTATIONS", JOHN WILEY, 1990
C AND IMPLEMENTS THE ENUMERATIVE ALGORITHM DESCRIBED IN
C SECTION  3.6.3 .
C
C THE INPUT PROBLEM MUST SATISFY THE CONDITIONS
C
C   1) 2 .LE. N .LE. JDIM - 1 ;
C   2) P(J), W(J), C  POSITIVE INTEGERS;
C   3) MAX (W(J)) .LE. C .
C
C MTU2   CALLS  5  PROCEDURES: CHMTU2, KSMALL, MTU1, REDU AND SORTR.
C KSMALL CALLS  8  PROCEDURES: BLD, BLDF, BLDS1, DETNS1, DETNS2,
C                              FORWD, MPSORT AND SORT7.
C
C THE PROGRAM IS COMPLETELY SELF-CONTAINED AND COMMUNICATION TO IT IS
C ACHIEVED SOLELY THROUGH THE PARAMETER LIST OF MTU2.
C NO MACHINE-DEPENDENT CONSTANT IS USED.
C THE PROGRAM IS WRITTEN IN 1967 AMERICAN NATIONAL STANDARD FORTRAN
C AND IS ACCEPTED BY THE PFORT VERIFIER (PFORT IS THE PORTABLE
C SUBSET OF ANSI DEFINED BY THE ASSOCIATION FOR COMPUTING MACHINERY).
C THE PROGRAM HAS BEEN TESTED ON A DIGITAL VAX 11/780 AND AN H.P.
C 9000/840.
C
C MTU2 NEEDS  8  ARRAYS ( P ,  W ,  X ,  PO ,  WO ,  XO ,  RR  AND
C                        PP ) OF LENGTH AT LEAST  JDIM .
C
C MEANING OF THE INPUT PARAMETERS:
C N    = NUMBER OF ITEM TYPES;
C P(J) = PROFIT OF EACH ITEM OF TYPE  J  (J=1,...,N);
C W(J) = WEIGHT OF EACH ITEM OF TYPE  J  (J=1,...,N);
C C    = CAPACITY OF THE KNAPSACK;
C JDIM = DIMENSION OF THE 8 ARRAYS;
C JFO  = 1 IF OPTIMAL SOLUTION IS REQUIRED,
C      = 0 IF APPROXIMATE SOLUTION IS REQUIRED;
C JCK  = 1 IF CHECK ON THE INPUT DATA IS DESIRED,
C      = 0 OTHERWISE.
C
C MEANING OF THE OUTPUT PARAMETERS:
C Z    = VALUE OF THE SOLUTION FOUND IF  Z .GT. 0 ,
C      = ERROR IN THE INPUT DATA (WHEN JCK=1) IF Z .LT. 0 : CONDI-
C        TION  - Z  IS VIOLATED;
C X(J) = NUMBER OF ITEMS OF TYPE  J  IN THE SOLUTION FOUND;
C JUB  = UPPER BOUND ON THE OPTIMAL SOLUTION VALUE (TO EVALUATE Z
C        WHEN JFO=0).
C
C ARRAYS PO, WO, XO, RR AND PP ARE DUMMY.
C
C ALL THE PARAMETERS BUT XO AND RR ARE INTEGER. ON RETURN OF MTU2
C ALL THE INPUT PARAMETERS ARE UNCHANGED.
C
      use iso_fortran_env
      implicit none

      integer(int64) :: n,c,z,jdim,jub
      integer :: jfo, jck
      INTEGER(int64) :: P(JDIM),X(JDIM),PO(JDIM)
      INTEGER(int64) :: WO(JDIM),PP(JDIM),W(JDIM)
      REAL(real64)    RR(JDIM),XO(JDIM)
      integer(int64) :: i,ib,icr,icrr,icws,if,if1,il,ip,ip1,ip2,ip3,is1
     *,is2,itrunc,iw1,iw2,iw3,ixo1,j,jj,jpk,jpx,jwk,k,kc,kf,kk
      real(real64) :: lim12,rk

      Z = 0
      IF ( JCK .EQ. 1 ) CALL CHMTU2(N,P,W,C,Z,JDIM)
      IF ( Z .LT. 0 ) RETURN
C
C HEURISTIC SOLUTION THROUGH THE CORE PROBLEM.
C
      KC = N
      IF ( N .LE. 200 ) GO TO 180
      DO 10 J=1,N
        RR(J) = (P(J))/real(W(J), real64)
   10 CONTINUE
      KC = N/100
      IF ( KC .LT. 100 ) KC = 100
      IF ( JFO .EQ. 0 ) KC = 100
      KK = N - KC + 1
      CALL KSMALL(N,RR,KK,(N+5)/6,XO)
      RK = RR(KK)
      IF = 0
      IL = N + 1
      DO 30 J=1,N
        RR(J) = real(P(J), real64)/real(W(J), real64)
        IF ( RR(J) .LT. RK ) GO TO 30
        IF ( RR(J) .EQ. RK ) GO TO 20
        IF = IF + 1
        PP(IF) = J
        GO TO 30
   20   IL = IL - 1
        PP(IL) = J
   30 CONTINUE
      IF ( IF .EQ. 0 ) GO TO 50
      CALL SORTR(IF,RR,PP,JDIM)
      DO 40 J=1,IF
        I = PP(J)
        PO(J) = P(I)
        WO(J) = W(I)
        W(I) = - W(I)
   40 CONTINUE
   50 IF1 = IF + 1
      DO 60 J=IF1,KC
        I = PP(IL)
        PO(J) = P(I)
        WO(J) = W(I)
        W(I) = - W(I)
        PP(J) = I
        IL = IL + 1
   60 CONTINUE
      JPK = PO(KC)
      JWK = WO(KC)
C REDUCTION OF THE CORE PROBLEM.
      CALL REDU(KC,PO,WO,JDIM,JPX,X)
      K = 0
      J = JPX
   70   K = K + 1
        PO(K) = PO(J)
        WO(K) = WO(J)
        PP(K) = PP(J)
        J = X(J)
      IF ( J .GT. 0 ) GO TO 70
      IF ( K .GT. 1 ) GO TO 80
      XO(1) = C/WO(1)
      IXO1 = XO(1)
      Z = PO(1)*IXO1
      JUB = Z + (C - WO(1)*IXO1)*JPK/JWK
      PO(2) = JPK
      WO(2) = JWK
      GO TO 90
C SOLUTION OF THE REDUCED CORE PROBLEM.
   80 CALL MTU1(K,PO,WO,C,RK,Z,XO,JDIM,JUB,X,RR)
   90 IF ( JFO .EQ. 0 .OR. Z .EQ. JUB ) GO TO 140
      IP1 = PO(1)
      IP2 = PO(2)
      IW1 = WO(1)
      IW2 = WO(2)
      IP3 = PO(3)
      IW3 = WO(3)
      IF ( K .GT. 2 ) GO TO 100
      IP3 = IP2
      IW3 = IW2
  100 DO 130 J=1,N
        X(J) = 0
        IF ( W(J) .GT. 0 ) GO TO 110
        W(J) = - W(J)
        GO TO 130
  110   ICR = C - W(J)
        IS1 = ICR/IW1
        IB = P(J) + IS1*IP1 + (ICR - IS1*IW1)*IP2/IW2
        IF ( IB .LE. Z ) GO TO 130
        ICRR = ICR - IS1*IW1
        IS2 = ICRR/IW2
        IP = P(J) + IS1*IP1 + IS2*IP2
        ICWS = ICRR - IS2*IW2
        IB = IP + ICWS*IP3/IW3
        ITRUNC = (IW2 - ICWS + IW1 - 1)/IW1
        LIM12 = IP + (ICWS + ITRUNC*IW1)*IP2/IW2 - ITRUNC*IP1
        IF ( LIM12 .GT. IB ) IB = LIM12
        IF ( IB .LE. Z ) GO TO 130
        DO 120 JJ=J,N
          W(JJ) = iabs64(W(JJ))
  120   CONTINUE
        GO TO 180
  130 CONTINUE
      GO TO 160
  140 DO 150 J=1,N
        X(J) = 0
        W(J) = iabs64(W(J))
  150 CONTINUE
  160 DO 170 J=1,K
        I = PP(J)
        X(I) = XO(J)
  170 CONTINUE
      JUB = Z
      RETURN
C
C SOLUTION THROUGH COMPLETE SORTING.
C
  180 DO 190 J=1,KC
        RR(J) = real(P(J), real64)/real(W(J), real64)
  190 CONTINUE
      DO 200 J=1,N
        PP(J) = J
  200 CONTINUE
      CALL SORTR(N,RR,PP,JDIM)
      DO 210 J=1,N
        I = PP(J)
        PO(J) = P(I)
        WO(J) = W(I)
  210 CONTINUE
C REDUCTION OF THE PROBLEM.
      CALL REDU(N,PO,WO,JDIM,JPX,X)
      KF = 0
      J = JPX
  220   KF = KF + 1
        PO(KF) = PO(J)
        WO(KF) = WO(J)
        PP(KF) = PP(J)
        J = X(J)
      IF ( J .GT. 0 ) GO TO 220
      IF ( KF .GT. 1 ) GO TO 230
      XO(1) = C/WO(1)
      IXO1 = XO(1)
      Z = PO(1)*IXO1
      JUB = Z
      GO TO 240
  230 CALL MTU1(KF,PO,WO,C,0._real64,Z,XO,JDIM,JUB,X,RR)
  240 DO 250 J=1,N
        X(J) = 0
  250 CONTINUE
      DO 260 J=1,KF
        I = PP(J)
        X(I) = XO(J)
  260 CONTINUE
      RETURN

      contains

      integer(int64) function iabs64(x)
c*********************************************************************72
c
cc iabs64 Seems like f2008 don't have an int64 version of iabs.
c
c  Licensing:
c
c    Public Domain. Unlicense.
c
c  Modified:
c
c    Mon, 11 Jul 2016 01:41:23 -0300
c
c  Author:
c
c    Henrique Becker
c
c  Parameters:
c
c    x Input, Name of the file with an sUKP instance.
c
      use iso_fortran_env
      implicit none
      integer(int64), intent(in) :: x

      if (x < 0) then
        iabs64 = -x
      else
        iabs64 = x
      endif

      return
      end function iabs64
      END

      SUBROUTINE CHMTU2(N,P,W,C,Z,JDIM)
C
C CHECK THE INPUT DATA.
C
      use iso_fortran_env
      implicit none

      integer(int64) JDIM,N
      INTEGER(int64) P(JDIM),W(JDIM),C,Z
              integer(int64) J
      IF ( N .GT. 1 .AND. N .LE. JDIM - 1 ) GO TO 10
      Z = - 1
      RETURN
   10 IF ( C .GT. 0 ) GO TO 30
   20 Z = - 2
      RETURN
   30 DO 40 J=1,N
        IF ( P(J) .LE. 0 ) GO TO 20
        IF ( W(J) .LE. 0 ) GO TO 20
        IF ( W(J) .GT. C ) GO TO 50
   40 CONTINUE
      RETURN
   50 Z = - 3
      RETURN
      END

      SUBROUTINE KSMALL(N,S,K,N6,SS)
C SUBROUTINE TO FIND THE  K-TH  SMALLEST OF  N  ELEMENTS
C IN  O(N)  TIME.
C ENTRANCE TO KSMALL IS ACHIEVED BY USING THE STATEMENT
C        CALL KSMALL(N,S,K,(N+5)/6,SS)
C
C THE VALUES OF THE FIRST THREE PARAMETERS MUST BE DEFINED
C BY THE USER PRIOR TO CALLING KSMALL. KSMALL NEEDS ONE
C ARRAY  ( S )  OF LENGTH  N  AND ONE ARRAY ( SS )  OF
C LENGTH  (N+5)/6  .THESE ARRAYS MUST BE DIMENSIONED BY THE
C USER IN THE CALLING PROGRAM.
C
C KSMALL CALLS EIGHT SUBROUTINES: BLD, BLDF, BLDS1, DETNS1,
C DETNS2, FORWD, MPSORT AND SORT7.
C THESE SUBROUTINES ARE COMPLETELY LOCAL, I.E. THE INFORMA-
C TION THEY NEED IS PASSED THROUGH THE PARAMETER LIST.
C THE WHOLE PROGRAM IS COMPLETELY SELF CONTAINED AND COMMU-
C NICATION WITH IT IS ACHIEVED SOLELY THROUGH THE PARAMETER
C LIST OF KSMALL. NO MACHINE DEPENDENT COSTANTS ARE USED.
C THE PROGRAM IS WRITTEN IN AMERICAN NATIONAL STANDARD
C FORTRAN AND IS ACCEPTED BY THE PFORT VERIFIER.
C THE PROGRAM HAS BEEN TESTED ON A  CDC CYBER 76 , ON A  CDC
C CYBER 730  AND ON A  DIGITAL VAX 11/780 .
C
C MEANING OF THE INPUT PARAMETERS:
C N = NUMBER OF ELEMENTS.
C S = ARRAY CONTAINING THE ELEMENTS.
C K = INTEGER VALUE INDICATING THAT THE  K-TH  SMALLEST
C     ELEMENT OF  S  MUST BE FOUND ( 1 .LE. K .LE. N ) .
C
C N ,  K  AND  N6  ARE INTEGER,  S  AND  SS  ARE REAL.
C ON RETURN, THE ELEMENTS OF  S  ARE REARRANGED SO THAT
C S(K)  CONTAINS THE  K-TH  SMALLEST ELEMENT OF  S , WHILE
C S(I) .LE. S(K)  IF  I .LT. K ,  S(I) .GE. S(K)  IF
C I .GT. K .
C THE CURRENT DIMENSIONS OF WORK ARRAYS  L ,  R  AND  T
C ALLOW USE OF THE CODE FOR PRACTICALLY ANY VALUE OF  N
C ( N .LT. 98*7**5 ).
C
C IN THE FOLLOWING, THE COMMENT SECTIONS REFER TO PROCEDURE
C KSMALL DESCRIBED IN  "A HYBRID ALGORITHM FOR FINDING
C THE  K-TH  SMALLEST OF  N  ELEMENTS IN  O(N)  TIME" , BY
C M. FISCHETTI AND S. MARTELLO, ANNALS OF OPERATIONAL
C RESEARCH 13, 1988.
C
      use iso_fortran_env
      implicit none

      integer(int64) :: n,k,n6
      real(real64), DIMENSION (N) :: S
      real(real64), DIMENSION (N6) :: SS
      INTEGER(int64) L(6),R(6),T(6)

      integer(int64) :: nn,nn7,ns1,ns12,ns2,nxt,i,jflag,lev,nlr,ii,il
     *,ir,it
      real(real64) :: v

      L(1) = 1
      R(1) = N
      T(1) = K
      LEV = 1
C
C STATEMENTS  1 - 10 .
C
   10 IF ( LEV .GT. 1 )  GO TO 20
      CALL FORWD(N,S,N6,SS,LEV,L,R,T,1_int64,V,JFLAG)
      GO TO 30
   20 CALL FORWD(N6,SS,N6,SS,LEV,L,R,T,R(LEV)+1,V,JFLAG)
   30 IF ( JFLAG .EQ. 0 ) GO TO 20
   40 LEV = LEV - 1
      IF ( LEV .EQ. 0 ) RETURN
      IL = L(LEV)
      IR = R(LEV)
      IT = T(LEV)
      NN = IR - IL + 1
      NN7 = NN/7
      II = IL + 7*(NN7 - 1)
      NXT = 1
      IF ( LEV .GT. 1 ) NXT = IR + 1
C
C STATEMENTS  11 - 13 .
C
C COMPUTE  NS1 = CARDINALITY OF SET  A1 .
      IF ( LEV .GT. 1 )  GO TO 50
      CALL DETNS1(N,S,N6,SS,IL,IR,II,NXT,V,NS1,NLR)
      GO TO 60
   50 CALL DETNS1(N6,SS,N6,SS,IL,IR,II,NXT,V,NS1,NLR)
   60 IF ( NS1 .LT. IT ) GO TO 90
C EXPLICITLY DETERMINE SET  A1 .
      IF ( LEV .GT. 1 ) GO TO 70
      CALL BLDF(N,S,N6,SS,IL,IR,NLR)
      GO TO 80
   70 CALL BLDS1(N6,SS,IL,II,NXT,NLR)
   80 R(LEV) = IL + NS1 - 1
      GO TO 10
   90 IF ( NS1 .LT. 11*NN/70 ) GO TO 110
C EXPLICITLY DETERMINE SET  A - A1 .
      T(LEV) = IT - NS1
      IF ( LEV .GT. 1 ) GO TO 100
      CALL BLDF(N,S,N6,SS,IL,IR,NLR)
      L(LEV) = IL + NS1
      GO TO 10
  100 CALL BLD(N6,SS,IL,IR,II,NXT,NLR)
      R(LEV) = IL + ( NN - NS1 ) - 1
      GO TO 10
C
C STATEMENTS  14 - 16 .
C
C COMPUTE  NS2 = CARDINALITY OF SET  A2 .
  110 IF ( LEV .GT. 1 ) GO TO 120
      CALL DETNS2(N,S,N6,SS,IL,IR,II,NXT,V,NS2,NLR)
      GO TO 130
  120 CALL DETNS2(N6,SS,N6,SS,IL,IR,II,NXT,V,NS2,NLR)
  130 NS12 = NS1 + NS2
      IF ( NS12 .LT. IT ) GO TO 160
      IF ( LEV .GT. 1 ) GO TO 40
      CALL BLDF(N,S,N6,SS,IL,IR,NLR)
      DO 140 I=1,NS12
        IF ( S(I) .EQ. V ) GO TO 150
  140 CONTINUE
  150 S(I) = S(K)
      S(K) = V
      RETURN
C EXPLICITLY DETERMINE SET  A - A1 - A2 .
  160 T(LEV) = IT - NS12
      IF ( LEV .GT. 1 ) GO TO 170
      CALL BLDF(N,S,N6,SS,IL,IR,NLR)
      L(LEV) = IL + NS12
      GO TO 10
  170 CALL BLD(N6,SS,IL,IR,II,NXT,NLR)
      R(LEV) = IL + ( NN - NS12 ) - 1
      GO TO 10
      END

      SUBROUTINE BLD(N6,SS,IL,IR,II,NXT,NLR)
C SUBROUTINE TO EXPLICITLY DETERMINE SET  A - A1  OR SET
C A - A1 - A2  WHEN LEV .GT. 1 .
      use iso_fortran_env
      implicit none

      integer(int64) :: n6,il,ir,ii,nxt,nlr,j,i,irr,next,ik,i6,ij
      real(real64), dimension (N6) :: SS
      J = IL - 1
      NEXT = NXT
      DO 30 I=IL,II,7
        IK = SS(NEXT) + 1.
        I6 = I + 6
        IF ( IK .GT. I6 ) GO TO 20
        DO 10 IJ=IK,I6
          J = J + 1
          SS(J) = SS(IJ)
   10   CONTINUE
   20   NEXT = NEXT + 1
   30 CONTINUE
      IRR = II + 7 + NLR
      IF ( IRR .GT. IR ) RETURN
      DO 40 IJ=IRR,IR
        J = J + 1
        SS(J) = SS(IJ)
   40 CONTINUE
      RETURN
      END

      SUBROUTINE BLDF(N,S,N6,SS,IL,IR,NLR)
C SUBROUTINE TO EXPLICITLY DETERMINE SET  A1  OR SET  A - A1
C OR SET  A - A1 - A2  WHEN  LEV .EQ. 1 .
      use iso_fortran_env
      implicit none

      integer(int64) :: n,n6,il,ir,nlr
      real(real64), DIMENSION (N) :: S
      real(real64), DIMENSION (N6) :: SS
      integer(int64) :: nn7,ics,icd,ius,ips,iud,ipd
      real(real64) :: ap

      NN7 = (IR - IL + 1)/7
      ICS = 1
      ICD = NN7 + 1
      IUS = IL + 6
      IPS = SS(1) + 1.
      IUD = IL + 7*NN7
      IPD = IUD + NLR - 1
   10 IF ( IPS .LE. IUS ) GO TO 20
      ICS = ICS + 1
      IF ( ICS .EQ. ICD ) RETURN
      IUS = IUS + 7
      IPS = SS(ICS) + 1.
      GO TO 10
   20 IF ( IPD .GE. IUD ) GO TO 30
      ICD = ICD - 1
      IF ( ICD .EQ. ICS ) RETURN
      IUD = IUD - 7
      IPD = SS(ICD)
      GO TO 20
   30 AP = S(IPS)
      S(IPS) = S(IPD)
      S(IPD) = AP
      IPS = IPS + 1
      IPD = IPD - 1
      GO TO 10
      END

      SUBROUTINE BLDS1(N6,SS,IL,II,NXT,NLR)
C SUBROUTINE TO EXPLICITLY DETERMINE SET  A1  WHEN
C LEV .GT. 1 .
      use iso_fortran_env
      implicit none

      integer(int64) :: n6,il,ii,nxt,nlr
      real(real64), DIMENSION (N6) :: SS
      integer(int64) :: J,NEXT,IK,I,IJ,IRR
      J = IL - 1
      NEXT = NXT
      DO 30 I=IL,II,7
        IK = SS(NEXT)
        IF ( IK .LT. I ) GO TO 20
        DO 10 IJ=I,IK
          J = J + 1
          SS(J) = SS(IJ)
   10   CONTINUE
   20   NEXT = NEXT + 1
   30 CONTINUE
      IK = II + 7
      IRR = IK + NLR - 1
      IF ( IK .GT. IRR ) RETURN
      DO 40 IJ=IK,IRR
        J = J + 1
        SS(J) = SS(IJ)
   40 CONTINUE
      RETURN
      END

      SUBROUTINE DETNS1(NA,A,N6,SS,IL,IR,II,NXT,V,NS1,NLR)
C SUBROUTINE TO COMPUTE THE CARDINALITY OF SET  A1 .
      use iso_fortran_env
      implicit none

      integer(int64) :: na,n6,il,ir,ii,nxt,ns1,nlr,i,irr,next
      real(real64) :: v
      real(real64), dimension (NA) :: A
      real(real64), dimension (N6) :: SS

      NS1 = 0
      NEXT = NXT
      DO 90 I=IL,II,7
        IF ( A(I+3) .LT. V ) GO TO 40
        IF ( A(I+1) .LT. V ) GO TO 20
        IF ( A(I) .LT. V ) GO TO 10
        SS(NEXT) = I - 1
        GO TO 80
   10   NS1 = NS1 + 1
        SS(NEXT) = I
        GO TO 80
   20   IF ( A(I+2) .LT. V ) GO TO 30
        NS1 = NS1 + 2
        SS(NEXT) = I + 1
        GO TO 80
   30   NS1 = NS1 + 3
        SS(NEXT) = I + 2
        GO TO 80
   40   IF ( A(I+5) .LT. V ) GO TO 60
        IF ( A(I+4) .LT. V ) GO TO 50
        NS1 = NS1 + 4
        SS(NEXT) = I + 3
        GO TO 80
   50   NS1 = NS1 + 5
        SS(NEXT) = I + 4
        GO TO 80
   60   IF ( A(I+6) .LT. V ) GO TO 70
        NS1 = NS1 + 6
        SS(NEXT) = I + 5
        GO TO 80
   70   NS1 = NS1 + 7
        SS(NEXT) = I + 6
   80   NEXT = NEXT + 1
   90 CONTINUE
      NLR = 0
      IRR = II + 7
      IF ( IRR .GT. IR ) RETURN
      DO 100 I=IRR,IR
        IF ( A(I) .GE. V ) GO TO 110
        NLR = NLR + 1
  100 CONTINUE
  110 NS1 = NS1 + NLR
      RETURN
      END

      SUBROUTINE DETNS2(NA,A,N6,SS,IL,IR,II,NXT,V,NS2,NLR)
C SUBROUTINE TO COMPUTE THE CARDINALITY OF SET  A2 .
      use iso_fortran_env
      implicit none

      integer(int64) :: na,n6,il,ir,ii,nxt,ns2,nlr
      real(real64) :: v
      real(real64), DIMENSION (NA) :: A
      real(real64), DIMENSION (N6) :: SS
      integer(int64) :: next,is,i6,i,j,ner,irr

      NS2 = 0
      NEXT = NXT
      DO 50 I=IL,II,7
        IS = SS(NEXT) + 1.
        I6 = I + 6
        IF ( IS .LE. I6 ) GO TO 10
        SS(NEXT) = I6
        GO TO 40
   10   DO 20 J=IS,I6
          IF ( A(J) .GT. V ) GO TO 30
   20   CONTINUE
        NS2 = NS2 + I6 - IS + 1
        SS(NEXT) = I6
        GO TO 40
   30   NS2 = NS2 + J - IS
        SS(NEXT) = J - 1
   40   NEXT = NEXT + 1
   50 CONTINUE
      IRR = II + 7 + NLR
      IF ( IRR .GT. IR ) RETURN
      NER = 0
      DO 60 I=IRR,IR
        IF ( A(I) .GT. V ) GO TO 70
        NER = NER + 1
   60 CONTINUE
   70 NS2 = NS2 + NER
      NLR = NLR + NER
      RETURN
      END

      SUBROUTINE FORWD(NA,A,N6,SS,LEV,L,R,T,NXT,V,JFLAG)
C SUBROUTINE TO PERFORM STATEMENTS  1 - 9 .
      use iso_fortran_env
      implicit none

      integer(int64) :: NA,N6,LEV,NXT,JFLAG,I,i1,i2,ii,ilc,imed,irc,it1
     *,itt,n1,n2,next,nn7
      real(real64) :: A,SS,V,AP,AUX,P

      DIMENSION A(NA),SS(N6)
      INTEGER(int64) L(6),R(6),T(6)

      integer(int64) :: IL,IR,IT,NN,ITARG
      IL = L(LEV)
      IR = R(LEV)
      IT = T(LEV)
      NN = IR - IL + 1
      ITARG = NN
C STATEMENT  1 .
      IF ( NN .GT. 97 ) GO TO 20
   10 CALL MPSORT(NA,A,IL,IR,IT,V)
      JFLAG = 1
      RETURN
C STATEMENT  2 .
   20 ITARG = 59*ITARG/70
      ILC = IL
      IMED = (IL + IR)/2
      P = A(IMED)
      IF ( A(IL) .LE. P ) GO TO 30
      A(IMED) = A(IL)
      A(IL) = P
      P = A(IMED)
   30 IRC = IR
      IF ( A(IR) .GE. P ) GO TO 50
      A(IMED) = A(IR)
      A(IR) = P
      P = A(IMED)
      IF ( A(IL) .LE. P ) GO TO 50
      A(IMED) = A(IL)
      A(IL) = P
      P = A(IMED)
      GO TO 50
   40 A(IRC) = A(ILC)
      A(ILC) = AUX
   50 IRC = IRC - 1
      IF ( A(IRC) .GT. P ) GO TO 50
      AUX = A(IRC)
   60 ILC = ILC + 1
      IF ( A(ILC) .LT. P ) GO TO 60
      IF ( ILC .LE. IRC ) GO TO 40
C STATEMENT  3 .
      IF ( IT .GT. ILC - IL ) GO TO 70
      IR = ILC - 1
      GO TO 80
C STATEMENT  4 .
   70 IT = IT - ( ILC - IL )
      IL = ILC
   80 NN = IR - IL + 1
      IF ( NN .LE. 97 ) GO TO 10
C STATEMENT  5 .
      IF ( NN .LE. ITARG ) GO TO 20
C STATEMENT  6 .
      JFLAG = 0
      L(LEV) = IL
      R(LEV) = IR
      T(LEV) = IT
      LEV = LEV + 1
      NN7 = NN/7
      II = IL + 7*(NN7 - 1)
      NEXT = NXT
      L(LEV) = NXT
      DO 90 I=IL,II,7
        CALL SORT7(NA,A,I)
        SS(NEXT) = A(I+3)
        NEXT = NEXT + 1
   90 CONTINUE
      I1 = II + 7
      I2 = IR - 1
  100 IF ( I1 .GT. I2 ) GO TO 120
      DO 110 I=I1,I2
        IF ( A(I) .LE. A(I+1) ) GO TO 110
        AP = A(I)
        A(I) = A(I+1)
        A(I+1) = AP
  110 CONTINUE
      I2 = I2 - 1
      GO TO 100
  120 R(LEV) = NEXT - 1
C STATEMENT  7 .
      IT1 = IT
      N1 = (11*NN + 279)/280
      IT = IT/7
      IF ( N1 .GT. IT ) IT = N1
      N2 = NN7 - N1 + 1
      IF ( N2 .LT. IT ) IT = N2
C STATEMENT  8 .
      IF ( IT .LE. (IT1 + 3)/4 ) GO TO 130
      T(LEV) = (IT1 + 3)/4
      RETURN
C STATEMENT  9 .
  130 ITT = NN7 - (NN - IT1 + 4)/4 + 1
      IF ( IT .LT. ITT ) IT = ITT
      T(LEV) = IT
      RETURN
      END

      SUBROUTINE MPSORT(NA,A,I1,I2,IT,V)
C SUBROUTINE TO REARRANGE THE ARRAY SEGMENT  A(I1:I2) SO
C THAT  A(IT+I1-1)  CONTAINS THE  IT-TH  SMALLEST ELEMENT.
      use iso_fortran_env
      implicit none

      integer(int64) :: na,i1,i2,it
      real(real64) :: v,ap,aux
      real(real64), dimension (na) :: a
      integer(int64) :: i,j,ita,irr,ij,ill
      I = I1
      J = I2
      ITA = IT + I1 - 1
   10 IF ( I .LT. J ) GO TO 20
      V = A(ITA)
      RETURN
   20 IRR = I
      IJ = (I + J)/2
      AP = A(IJ)
      IF ( A(I) .LE. AP ) GO TO 30
      A(IJ) = A(I)
      A(I) = AP
      AP = A(IJ)
   30 ILL = J
      IF ( A(J) .GE. AP ) GO TO 50
      A(IJ) = A(J)
      A(J) = AP
      AP = A(IJ)
      IF ( A(I) .LE. AP ) GO TO 50
      A(IJ) = A(I)
      A(I) = AP
      AP = A(IJ)
      GO TO 50
   40 A(ILL) = A(IRR)
      A(IRR) = AUX
   50 ILL = ILL - 1
      IF ( A(ILL) .GT. AP ) GO TO 50
      AUX = A(ILL)
   60 IRR = IRR + 1
      IF ( A(IRR) .LT. AP ) GO TO 60
      IF ( IRR .LE. ILL ) GO TO 40
      IF ( ITA .LT. IRR ) GO TO 70
      I = IRR
      GO TO 80
   70 J = ILL
   80 IF ( J - I .GT. 10 ) GO TO 20
      IF ( I .EQ. I1 ) GO TO 10
      I = I - 1
   90 I = I + 1
      IF ( I .NE. J ) GO TO 100
      V = A(ITA)
      RETURN
  100 AP = A(I+1)
      IF ( A(I) .LE. AP ) GO TO 90
      IRR = I
  110 A(IRR+1) = A(IRR)
      IRR = IRR - 1
      IF ( AP .LT. A(IRR) ) GO TO 110
      A(IRR+1) = AP
      GO TO 90
      END

      SUBROUTINE SORT7(NA,A,I)
C SUBROUTINE TO SORT IN INCREASING ORDER THE ELEMENTS FROM
C A(I)  TO  A(I+6)  OF  A  BY PERFORMING AT MOST  13  TESTS.
      use iso_fortran_env
      implicit none

      integer(int64) :: NA,I
      real(real64), dimension (NA) :: A
      integer(int64) :: I1,I2,I3,I4,I5,I6
      real(real64) :: A1,A2,A3,A4,AUX,A5,A6

      I1 = I + 1
      I2 = I + 2
      I3 = I + 3
      I4 = I + 4
      I5 = I + 5
      I6 = I + 6
      IF ( A(I) .GT. A(I1) ) GO TO 10
      A1 = A(I)
      A2 = A(I1)
      GO TO 20
   10 A1 = A(I1)
      A2 = A(I)
   20 IF ( A(I2) .GT. A(I3) ) GO TO 30
      A3 = A(I2)
      A4 = A(I3)
      GO TO 40
   30 A3 = A(I3)
      A4 = A(I2)
   40 IF ( A1 .GT. A3 ) GO TO 50
      A5 = A2
      A2 = A3
      A3 = A4
      GO TO 60
   50 A5 = A4
      AUX = A3
      A3 = A2
      A2 = A1
      A1 = AUX
   60 A4 = A(I4)
      IF ( A4 .GE. A2 ) GO TO 80
      IF ( A4 .GE. A1 ) GO TO 70
      A4 = A3
      A3 = A2
      A2 = A1
      A1 = A(I4)
      GO TO 90
   70 A4 = A3
      A3 = A2
      A2 = A(I4)
      GO TO 90
   80 IF ( A4 .GE. A3 ) GO TO 90
      A4 = A3
      A3 = A(I4)
   90 A(I) = A1
      IF ( A5 .GT. A3 ) GO TO 110
      A(I3) = A3
      A(I4) = A4
      IF ( A5 .GT. A2 ) GO TO 100
      A(I1) = A5
      A(I2) = A2
      GO TO 130
  100 A(I1) = A2
      A(I2) = A5
      GO TO 130
  110 A(I1) = A2
      A(I2) = A3
      IF ( A5 .GT. A4 ) GO TO 120
      A(I3) = A5
      A(I4) = A4
      GO TO 130
  120 A(I3) = A4
      A(I4) = A5
  130 A5 = A(I5)
      IF ( A5 .LT. A(I2) ) GO TO 150
      IF ( A5 .LT. A(I3) ) GO TO 140
      IF ( A5 .GE. A(I4) ) GO TO 180
      A(I5) = A(I4)
      A(I4) = A5
      GO TO 180
  140 A(I5) = A(I4)
      A(I4) = A(I3)
      A(I3) = A5
      GO TO 180
  150 A(I5) = A(I4)
      A(I4) = A(I3)
      A(I3) = A(I2)
      IF ( A5 .LT. A(I1) ) GO TO 160
      A(I2) = A5
      GO TO 180
  160 A(I2) = A(I1)
      IF ( A5 .LT. A(I) ) GO TO 170
      A(I1) = A5
      GO TO 180
  170 A(I1) = A(I)
      A(I) = A5
  180 A6 = A(I6)
      IF ( A6 .LT. A(I3) ) GO TO 200
      IF ( A6 .LT. A(I4) ) GO TO 190
      IF ( A6 .GE. A(I5) ) RETURN
      A(I6) = A(I5)
      A(I5) = A6
      RETURN
  190 A(I6) = A(I5)
      A(I5) = A(I4)
      A(I4) = A6
      RETURN
  200 A(I6) = A(I5)
      A(I5) = A(I4)
      A(I4) = A(I3)
      IF ( A6 .LT. A(I1) ) GO TO 220
      IF ( A6 .LT. A(I2) ) GO TO 210
      A(I3) = A6
      RETURN
  210 A(I3) = A(I2)
      A(I2) = A6
      RETURN
  220 A(I3) = A(I2)
      A(I2) = A(I1)
      IF ( A6 .LT. A(I) ) GO TO 230
      A(I1) = A6
      RETURN
  230 A(I1) = A(I)
      A(I) = A6
      RETURN
      END
      SUBROUTINE MTU1(N,P,W,C,RN,Z,X,JDIM,JUB,XX,MIN)
C
C THIS SUBROUTINE SOLVES THE UNBOUNDED SINGLE KNAPSACK PROBLEM
C
C MAXIMIZE  Z = P(1)*X(1) + ... + P(N)*X(N)
C
C SUBJECT TO:   W(1)*X(1) + ... + W(N)*X(N) .LE. C ,
C               X(J) .GE. 0 AND INTEGER  FOR J=1,...,N.
C
C THE PROGRAM IS BASED ON THE BRANCH-AND-BOUND ALGORITHM PRESENTED IN
C  S. MARTELLO, P. TOTH, "BRANCH AND BOUND ALGORITHMS FOR THE SOLUTION
C  OF THE GENERAL UNIDIMENSIONAL KNAPSACK PROBLEM", IN M. ROUBENS, ED.,
C  "ADVANCES IN OPERATIONS RESEARCH", NORTH HOLLAND, 1977.
C
      use iso_fortran_env
      implicit none

      integer(int64) n,c,z,jdim,jub
      INTEGER(int64) P(JDIM),W(JDIM)
      INTEGER(int64) XX(JDIM),CWS,CWF,DIFF,R,S,S1,S2,T,PROFIT,PS
      REAL(real64)   X(JDIM),MIN(JDIM)
      integer(int64) i,ib,icr,icrr,icwd,icws,if,if1,il,ip,ip1,ip2,ip3
      integer(int64) itrunc,iw1,iw2,iw3,ixo1,j,jj,jpk,jwk,k,kc,kf,kk
      integer(int64) ii,ii1,kk1,mink,nn
      real(real64) lim,lim12,lim2,rn
C
C STEP 1.
C
      CWF = C
      S1 = C/W(1)
      S2 = (C - S1*W(1))/W(2)
      IP = S1*P(1) + S2*P(2)
      CWS = C - S1*W(1) - S2*W(2)
      IF ( CWS .NE. 0 ) GO TO 20
      Z = IP
      JUB = Z
      X(1) = S1
      X(2) = S2
      IF ( N .EQ. 2 ) RETURN
      DO 10 J=3,N
        X(J) = 0
   10 CONTINUE
      RETURN
   20 MINK = C + 1
      MIN(N) = MINK
      DO 30 J=2,N
        K = N + 2 - J
        IF ( W(K) .LT. MINK ) MINK = W(K)
        MIN(K-1) = MINK
   30 CONTINUE
      W(N+1) = C + 1
      P(N+1) = 0
      LIM = IP + CWS*P(3)/W(3)
c      IF ( N .EQ. 2 ) LIM = FLOAT(IP) + FLOAT(CWS)*RN
      IF ( N .EQ. 2 ) LIM = real(IP, real64) + real(CWS, real64)*RN
      ITRUNC = (W(2) - CWS + W(1) - 1)/W(1)
      LIM12 = IP + (CWS + ITRUNC*W(1))*P(2)/W(2) - ITRUNC*P(1)
      IF ( LIM12 .GT. LIM ) LIM = LIM12
      JUB = LIM
      Z = 0
      XX(1) = S1
      XX(2) = S2
      IF ( N .EQ. 2 ) GO TO 50
      DO 40 J=3,N
        XX(J) = 0
   40 CONTINUE
   50 PROFIT = IP
      C = CWS
      II = 2
      GO TO 110
C
C STEP 2.
C
   60 S = C/W(II)
      IF ( S .GT. 0 ) GO TO 70
      IF ( Z .GE. PROFIT + C*P(II+1)/W(II+1) ) GO TO 120
      II = II + 1
      GO TO 60
C
C STEP 3.
C
   70 PS = PROFIT + S*P(II)
      CWS = C - S*W(II)
      IF ( ( CWS .EQ. 0 ) .OR. ( II .EQ. N ) ) GO TO 80
      IF ( Z .GE. PS + CWS*P(II+1)/W(II+1) ) GO TO 150
      C = CWS
      PROFIT = PS
      XX(II) = S
      GO TO 110
   80 IF ( Z .GE. PS ) GO TO 150
      Z = PS
      II1 = II - 1
      DO 90 J=1,II1
        X(J) = XX(J)
   90 CONTINUE
      X(II) = S
      II1 = II + 1
      DO 100 J=II1,N
        X(J) = 0
  100 CONTINUE
      IF ( Z .NE. LIM ) GO TO 150
      C = CWF
      RETURN
C
C STEP 4.
C
  110 II = II + 1
      IF ( C .GE. INT(MIN(II-1)) ) GO TO 60
C
C STEP 5.
C
  120 IF ( Z .GE. PROFIT ) GO TO 140
      Z = PROFIT
      DO 130 J=1,N
        X(J) = XX(J)
  130 CONTINUE
      IF ( Z .NE. LIM ) GO TO 140
      C = CWF
      RETURN
  140 IF ( XX(N) .EQ. 0 ) GO TO 150
      C = C + XX(N)*W(N)
      PROFIT = PROFIT - XX(N)*P(N)
      XX(N) = 0
C
C STEP 6.
C
  150 IB = II - 1
      DO 160 J=1,IB
        KK = II - J
        IF ( XX(KK) .GT. 0 ) GO TO 170
  160 CONTINUE
      C = CWF
      RETURN
  170 R = C
      C = C + W(KK)
      PROFIT = PROFIT - P(KK)
      XX(KK) = XX(KK) - 1
      IF ( Z .LT. PROFIT + C*P(KK + 1)/W(KK + 1) ) GO TO 180
      C = C + XX(KK)*W(KK)
      PROFIT = PROFIT - XX(KK)*P(KK)
      XX(KK) = 0
      II = KK + 1
      GO TO 150
  180 IF ( R .LT. INT(MIN(KK)) ) GO TO 190
      II = KK + 1
      GO TO 60
  190 NN = KK + 1
      II = KK + 1
C
C STEP 7.
C
  200 DIFF = W(NN) - W(KK)
      IF ( DIFF ) 210,260,220
  210 T = R - DIFF
      IF ( T .LT. INT(MIN(NN-1)) ) GO TO 260
      S = C/W(NN)
      II = NN
      GO TO 70
  220 IF ( DIFF .GT. R ) GO TO 260
      IF ( Z .GE. PROFIT + P(NN) ) GO TO 260
      Z = PROFIT + P(NN)
      DO 230 J=1,KK
        X(J) = XX(J)
  230 CONTINUE
      KK1 = KK + 1
      DO 240 J=KK1,N
        X(J) = 0
  240 CONTINUE
      X(NN) = 1
      IF ( Z .NE. LIM ) GO TO 250
      C = CWF
      RETURN
  250 R = R - DIFF
      KK = NN
C
C STEP 8.
C
  260 IF ( Z .GE. PROFIT + C*P(NN+1)/W(NN+1) ) GO TO 150
      NN = NN + 1
      GO TO 200
      END

      SUBROUTINE REDU(N,PO,WO,JDIM,JPX,X)
C
C REDUCE AN UNBOUNDED KNAPSACK PROBLEM (PO,WO) THROUGH DOMINANCE
C RELATIONS.
C ON OUTPUT, JPX IS THE FIRST UNDOMINATED ITEM, X(JPX) THE SECOND, AND
C SO ON. IF Y IS THE LAST ONE, THEN X(Y) = 0.
C
      use iso_fortran_env
      implicit none

      integer(int64) :: N,JDIM,JPX
      INTEGER(int64) :: PO(JDIM),WO(JDIM),X(JDIM)
      integer(int64) :: FEQ,PRFEQ,PRJ,PRK
      integer(int64) :: j,ipoj,iwoj,k
      real(real64) :: crat,rj

C INITIALIZATION.
      JPX = 1
      DO 10 J=1,N
        X(J) = J + 1
   10 CONTINUE
      X(N) = 0
      CRAT = real(PO(1), real64)/real(WO(1), real64) + 1.
      PRFEQ = 0
      PRJ = 0
C MAIN ITERATION.
      J = JPX
   20   IWOJ = WO(J)
        IPOJ = PO(J)
        RJ = real(IPOJ, real64)/real(IWOJ, real64)
        IF ( RJ .EQ. CRAT ) GO TO 30
        CRAT = RJ
        PRFEQ = PRJ
        FEQ = J
        GO TO 80
C ITEMS K PRECEDING J WITH SAME RATIO.
   30   K = FEQ
        PRK = PRFEQ
   40     IF ( (WO(K)/IWOJ)*IPOJ .LT. PO(K) ) GO TO 60
C ITEM J DOMINATES ITEM K.
          IF ( PRK .EQ. 0 ) GO TO 50
          X(PRK) = X(K)
          GO TO 70
   50     JPX = X(K)
          GO TO 70
   60     PRK = K
   70     K = X(K)
        IF ( K .LT. J ) GO TO 40
C ITEMS K FOLLOWING J.
   80   K = X(J)
        PRK = J
   90     IF ( K .EQ. 0 ) GO TO 120
          IF ( (WO(K)/IWOJ)*IPOJ .LT. PO(K) ) GO TO 100
C ITEM J DOMINATES ITEM K.
          X(PRK) = X(K)
          GO TO 110
  100     PRK = K
  110     K = X(K)
        GO TO 90
  120   PRJ = J
        J = X(J)
      IF ( J .GT. 0 ) GO TO 20
      RETURN
      END
      SUBROUTINE SORTR(N,A,V,JDA)
C
C SORT THE REAL ARRAY A BY DECREASING VALUES (DERIVED FROM SUBROUTINE
C SORTZV OF THE C.E.R.N. LIBRARY).
C
C JDA           = LENGTH OF ARRAY A;
C N             = NUMBER OF ELEMENTS OF A TO BE SORTED;
C V(I) (INPUT)  = POINTER TO THE I-TH ELEMENT TO BE SORTED;
C V(I) (OUTPUT) = POINTER TO THE I-TH ELEMENT OF THE SORTED ARRAY.
C
C ON RETURN, ARRAY A IS UNCHANGED.
C
      use iso_fortran_env
      implicit none

      integer(int64) N,JDA
      INTEGER(int64) V(N),IU(20),IL(20)
      REAL(real64)   A(JDA)
      integer(int64) II,JJ,M,I,J,K,IJ,IV,IVT,KI,L
      REAL(real64)   T

      II = 1
      JJ = N
      IF ( N .LE. 1 ) RETURN
      M = 1
      I = II
      J = JJ
   10 IF ( I .GE. J ) GO TO 80
   20 K = I
      IJ = (J + I)/2
      IV = V(IJ)
      T = A(IV)
      KI = V(I)
      IF ( A(KI) .GE. T ) GO TO 30
      V(IJ) = KI
      V(I) = IV
      IV = V(IJ)
      T = A(IV)
   30 L = J
      KI = V(J)
      IF ( A(KI) .LE. T ) GO TO 50
      V(IJ) = KI
      V(J) = IV
      IV = V(IJ)
      T = A(IV)
      KI = V(I)
      IF ( A(KI) .GE. T ) GO TO 50
      V(IJ) = KI
      V(I) = IV
      IV = V(IJ)
      T = A(IV)
      GO TO 50
   40 V(L) = V(K)
      V(K) = IVT
   50 L = L - 1
      KI = V(L)
      IF ( A(KI) .LT. T ) GO TO 50
      IVT = KI
   60 K = K + 1
      KI = V(K)
      IF ( A(KI) .GT. T ) GO TO 60
      IF ( K .LE. L ) GO TO 40
      IF ( L - I .LE. J - K ) GO TO 70
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 90
   70 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 90
   80 M = M - 1
      IF ( M .EQ. 0 ) RETURN
      I = IL(M)
      J = IU(M)
   90 IF ( J - I .GE. II ) GO TO 20
      IF ( I .EQ. II ) GO TO 10
      I = I - 1
  100 I = I + 1
      IF ( I .EQ. J ) GO TO 80
      IV = V(I+1)
      T = A(IV)
      KI = V(I)
      IF ( A(KI) .GE. T ) GO TO 100
      K = I
  110 V(K+1) = V(K)
      K = K - 1
      KI = V(K)
      IF ( T .GT. A(KI) ) GO TO 110
      V(K+1) = IV
      GO TO 100
      END


! Updated 10/24/2001.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!   Program 4.4   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                       !
! Please Note:                                                          !
!                                                                       !
! (1) This computer program is written by Tao Pang in conjunction with  !
!     his book, "An Introduction to Computational Physics," published   !
!     by Cambridge University Press in 1997.                            !
!                                                                       !
! (2) No warranties, express or implied, are made for this program.     !
!                                                                       !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
SUBROUTINE MIGS (A,N,X,INDX)
!
! Subroutine to invert matrix A(N,N) with the inverse stored
! in X(N,N) in the output.  Copyright (c) Tao Pang 2001.
!
  use share, only   : dp
  IMPLICIT NONE
  INTEGER, INTENT (IN) :: N
  INTEGER :: I,J,K
  INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
  REAL(dp), INTENT (IN), DIMENSION (N,N):: A
  REAL(dp), INTENT (OUT), DIMENSION (N,N):: X
  REAL(dp), DIMENSION (N,N) :: B
!
  DO I = 1, N
    DO J = 1, N
      B(I,J) = 0.0
    END DO
  END DO
  DO I = 1, N
    B(I,I) = 1.0
  END DO
!
  CALL ELGS (A,N,INDX)
!
  DO I = 1, N-1
    DO J = I+1, N
      DO K = 1, N
        B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
      END DO
    END DO
  END DO
!
  DO I = 1, N
    X(N,I) = B(INDX(N),I)/A(INDX(N),N)
    DO J = N-1, 1, -1
      X(J,I) = B(INDX(J),I)
      DO K = J+1, N
        X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
      END DO
      X(J,I) =  X(J,I)/A(INDX(J),J)
    END DO
  END DO
END SUBROUTINE MIGS
!
SUBROUTINE ELGS (A,N,INDX)
!
! Subroutine to perform the partial-pivoting Gaussian elimination.
! A(N,N) is the original matrix in the input and transformed matrix
! plus the pivoting element ratios below the diagonal in the output.
! INDX(N) records the pivoting order.  Copyright (c) Tao Pang 2001.
!
  use share, only   : dp
  IMPLICIT NONE
  INTEGER, INTENT (IN) :: N
  INTEGER :: I,J,K,ITMP
  INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
  REAL(dp) :: C1,PI,PI1,PJ
  REAL(dp), INTENT (INOUT), DIMENSION (N,N) :: A
  REAL(dp), DIMENSION (N) :: C
!
! Initialize the index
!
  DO I = 1, N
    INDX(I) = I
  END DO
!
! Find the rescaling factors, one from each row
!
  DO I = 1, N
    C1= 0.0
    DO J = 1, N
      C1 = AMAX1(C1,ABS(A(I,J)))
    END DO
    C(I) = C1
  END DO
!
! Search the pivoting (largest) element from each column
!
  DO J = 1, N-1
    PI1 = 0.0
    DO I = J, N
      PI = ABS(A(INDX(I),J))/C(INDX(I))
      IF (PI.GT.PI1) THEN
        PI1 = PI
        K   = I
      ENDIF
    END DO
!
! Interchange the rows via INDX(N) to record pivoting order
!
    ITMP    = INDX(J)
    INDX(J) = INDX(K)
    INDX(K) = ITMP
    DO I = J+1, N
      PJ  = A(INDX(I),J)/A(INDX(J),J)
!
! Record pivoting ratios below the diagonal
!
      A(INDX(I),J) = PJ
!
! Modify other elements accordingly
!
      DO K = J+1, N
        A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
      END DO
    END DO
  END DO
!
END SUBROUTINE ELGS


!==============================================================================!
  program Two_Point_Correlation
!------------------------------------------------------------------------------!
!   Program to extract two point correlations from T-Flows' monitoring files   !
!                                                                              !
!   The algorithm is taken from here:                                          !
!   https://nptel.ac.in/courses/112104118/lecture-32/32-4_correlation_fn.htm   !
!------------------------------------------------------------------------------!
  implicit none
!------------------------------------------------------------------------------!
  character(len= 80)        :: file_name = 'rb_conv-monit.001'
  character(len=300)        :: one_line
  integer                   :: k, n, dum
  integer, parameter        :: N_POINTS     =    40
  integer, parameter        :: N_TIME_STEPS = 12000
  real, allocatable, target :: u(:,:), v(:,:), w(:,:), p(:,:), t(:,:)
  real, allocatable         :: r(:), s1(:), s2(:)
  real, pointer             :: phi(:,:)
!------------------------------------------------------------------------------!

  !---------------------!
  !   Allocate memory   !
  !---------------------!
  allocate(u(N_TIME_STEPS, N_POINTS))
  allocate(v(N_TIME_STEPS, N_POINTS))
  allocate(w(N_TIME_STEPS, N_POINTS))
  allocate(p(N_TIME_STEPS, N_POINTS))
  allocate(t(N_TIME_STEPS, N_POINTS))
  allocate(r (N_POINTS))
  allocate(s1(N_POINTS))
  allocate(s2(N_POINTS))

  !-------------------------------------------!
  !   Chose the variable for which you want   !
  !   to extract the two point correlations   !
  !-------------------------------------------!
  phi => u

  !-------------------------------------------!
  !   Read all monitoring points from files   !
  !-------------------------------------------!
  do k = 1, N_POINTS
    write(file_name(15:17), '(i3.3)'), k

    open(9, file=file_name)

      ! Skip first line (which just gives coordinates)
      read(9,'(a300)', end=1) one_line

      do n = 1, N_TIME_STEPS
        read(9, *) dum, u(n,k), v(n,k), w(n,k), p(n,k), t(n,k)
      end do

    close(9)
  end do

  !-------------------------------------!
  !   Work out two point correlations   !
  !-------------------------------------!
  r (:) = 0.0
  s1(:) = 0.0
  s2(:) = 0.0

  ! Accumulate over time steps
  do n = 1, N_TIME_STEPS

    ! For all points
    do k = 1, N_POINTS
      r (k) = r (k) + phi(n,1) * phi(n,k)  ! variable
      s1(k) = s1(k) + phi(n,1)**2          ! first sum
      s2(k) = s2(k) + phi(n,k)**2          ! second sum
    end do
  end do

  ! Time average
  r (:) = r (:) / N_TIME_STEPS
  s1(:) = s1(:) / N_TIME_STEPS
  s2(:) = s2(:) / N_TIME_STEPS

  ! Print correlation
  do k = 1, N_POINTS
    print *, k, r(k) / sqrt(s1(k)*s2(k))
  end do

  ! Error trap if end of file was reached
1 continue

  end program


program leap_year
    implicit none
    integer :: year
    logical :: has_error

    year = 1899
    print *, year, is_leap_year(year)
    print *, 'year is now', year
    print *, 1448, is_leap_year(1448, has_error=has_error)
    if (has_error) &
        print *, 'opsie'

contains

    function is_leap_year(year, has_error) result(is_leap)
        implicit none
        integer, intent(in) :: year
        logical, optional, intent(out) :: has_error
        logical :: is_leap

        if (present(has_error)) then
            has_error = year <= 1582
        end if
        if (mod(year, 4) == 0) then
            if (mod(year, 100) == 0) then
                if (mod(year, 400) == 0) then
                    is_leap = .false.
                else
                    is_leap = .true.
                end if
            else
                is_leap = .true.
            end if
        else
            is_leap = .false.
        end if
    end function is_leap_year

end program leap_year


MODULE mod_3Ddiffusion

  USE mod_precision
  USE mod_configure
  USE mod_cst
  USE mod_lun
  USE mod_namelist
  USE mod_memory
  USE mod_mpi
  USE mod_output

CONTAINS

  !====================================!
  !- ARRAY INITILIZATON (First guess) -!
  !====================================!
  SUBROUTINE sub_3Ddiff_initialisation(f_p,fn_p)

    IMPLICIT NONE
    REAL(kind = rprec), INTENT(out), DIMENSION(:, :, :), POINTER :: f_p
    REAL(kind = rprec), INTENT(out), DIMENSION(:, :, :), POINTER :: fn_p

    INTEGER(kind =iprec) :: ix, iy, iz
    REAL(kind = rprec) :: xx, yy, zz, kk
    REAL(kind = rprec) :: maxval_fp

    ALLOCATE( f_p(sx-halo_x:ex+halo_x, sy-halo_y:ey+halo_y, sz-halo_z:ez+halo_z))
    ALLOCATE(fn_p(sx-halo_x:ex+halo_x, sy-halo_y:ey+halo_y, sz-halo_z:ez+halo_z))

    fn_p(:,:,:) = rZero

    kk = rTwo*Pi

	DO iz = sz-1, ez+1
       DO iy = sy-1, ey+1
          DO ix = sx-1, ex+1

             xx = dx*(REAL(ix - iOne - halo_x, kind=rprec) + rHalf)
             yy = dy*(REAL(iy - iOne - halo_y, kind=rprec) + rHalf)
             zz = dz*(REAL(iz - iOne - halo_z, kind=rprec) + rHalf)

             f_p(ix,iy,iz)           = &
                  0.125_rprec        * &
                  (rOne - COS(kk*xx))* &
                  (rOne - COS(kk*yy))* &
                  (rOne - COS(kk*zz))
          END DO
       END DO
	END DO

  END SUBROUTINE sub_3Ddiff_initialisation

  !============!
  !- MAINLOOP -!
  !============!
  SUBROUTINE sub_3Ddiff_mainloop(f_p, fn_p)

    IMPLICIT NONE

    REAL(kind = rprec), INTENT(inout), DIMENSION(:, :, :), POINTER :: f_p
    REAL(kind = rprec), INTENT(inout), DIMENSION(:, :, :), POINTER :: fn_p

    REAL(kind = rprec), DIMENSION(:, :, :), POINTER :: temp_p
    REAL(kind = rprec) :: coeff_east_west, coeff_north_south, coeff_top_bottom, coeff_center
    REAL(kind = rprec) :: maxval_fp, maxval_fnp
    INTEGER(kind = iprec) :: icnt
	INTEGER(kind = iprec) :: ix, iy, iz

    coeff_east_west   = kappa*dt/(dx*dx)
    coeff_north_south = kappa*dt/(dy*dy)
    coeff_top_bottom  = kappa*dt/(dz*dz)
    coeff_center      = rOne - (rTwo * coeff_east_west + rTwo * coeff_north_south + rTwo * coeff_top_bottom)

    IF (rank == iZero) THEN

       WRITE(lun_standard,*)''
       WRITE(lun_standard,*) "3D Diffusion (fortran)"
       WRITE(lun_standard,*)''
       WRITE(lun_standard,"(A, I4, A, I4, A, I4, A,E13.5,A,E13.5,A,E13.5)") &
            "X:", dim_x, ", Y:", dim_y, ", Z:", dim_z, ", &
            kappa:", kappa, ", dt:", dt, ", dx:", dx
       WRITE(*,*)" coeffs:", coeff_east_west, coeff_north_south, coeff_top_bottom, coeff_center
       WRITE(lun_standard,*)''

    ENDIF

    !-------------------------!
    !- MAIN Loop (time loop) -!
    !-------------------------!
    icnt = iZero
    time = rZero

    CALL sub_mpi_maxval(maxval_fp, f_p)

    IF (rank == iZero) THEN
       WRITE(lun_standard,"(A,I5,A,F7.4,A,F7.4,A)") &
            "time after iteration ", icnt+1, ": ", time, &
            " sec (maxval= ", maxval_fp,')'
    ENDIF

    IF (ncoutput) CALL mod_output_write(f_p(sx:ex,sy:ey,sz:ez))

    DO
       icnt = icnt + iOne

       CALL sub_mpi_communication(f_p)

       DO iz = sz, ez
          DO iy = sy, ey
             DO ix = sx, ex
                fn_p(ix,iy,iz) = &
                     coeff_center      * f_p(ix,iy,iz)   + &
                     coeff_east_west   * f_p(ix+1,iy,iz) + coeff_east_west   * f_p(ix-1,iy,iz) + &
                     coeff_north_south * f_p(ix,iy+1,iz) + coeff_north_south * f_p(ix,iy-1,iz) + &
                     coeff_top_bottom  * f_p(ix,iy,iz+1) + coeff_top_bottom  * f_p(ix,iy,iz-1)
             END DO
          END DO
       END DO

       CALL sub_mpi_boundary_conditions(fn_p)

       temp_p => f_p
       f_p    => fn_p
       fn_p   => temp_p

       time = time + dt

       CALL sub_mpi_maxval(maxval_fp, f_p)
       CALL sub_mpi_maxval(maxval_fnp, fn_p)

       IF (rank == iZero) THEN
          IF((ncoutput).AND.(MODULO(icnt,frequency) .EQ. 0)) THEN
             WRITE(lun_standard,"(A,I5,A,F7.4,A,F16.12,A,F7.4,A)") &
                  "time after iteration ", icnt, ": ", time, &
                  "sec (maxval f_p= ",maxval_fp ,', maxval fn_p',maxval_fnp,')'
          END IF
       END IF

       IF((ncoutput).AND.(MODULO(icnt,frequency) .EQ. 0)) THEN
          CALL mod_output_write(f_p(sx:ex,sy:ey,sz:ez))
       ENDIF

       IF ((time + rHalf*dt >= time_max) .OR. (icnt >= 1000)) EXIT

    END DO

    IF (rank == iZero) THEN
       WRITE(lun_standard,"(A,I5,A,F16.12,A,F7.4,A)") &
                  "time after iteration ", icnt, ": ", time, &
                  " sec (maxval= ", maxval_fp,')'
    ENDIF

  END SUBROUTINE sub_3Ddiff_mainloop

END MODULE mod_3Ddiffusion


! Advent of Code 2021 : https://adventofcode.com/2021
! Puzzle for Day 06 part 02 :
! Build with:  gfortran -static-libgcc -o aoc_day06_p2 aoc_day06_p2.f90

! Run time on Apple mac Mini M1 (arm64) :  .007 of a seconds
! ./aoc_day06_p2  0.00s user 0.00s system 62% cpu 0.007 total

! Thanks to Steve Lionel (sblionel) for sharing his 'part 2' solution on the Fortran
! Language Discourse. This helped me to understand how to 'fix' my rather poor part 1
! effort - which would probably still be running had I stuck with that approach :)
! See post: https://fortran-lang.discourse.group/t/advent-of-code-2021/2346/17

program aoc_day06_p1

	use, intrinsic :: iso_fortran_env
	implicit none

	! Declare and set constants the AOC day and part
	integer,parameter :: day = 6, part = 2

	! Declare file related variables
	character(len=*), parameter :: filename = "day06-input.txt"
	character(len=*), parameter :: error1 = "file: '"//''//filename//''//"' not found"

	! Variables to track and manage the program
	integer (8) :: total_fish = 0
	integer,parameter :: cycles = 256  ! daily cycles (18 = test / 80 = part 1/ 256 = part2)
	integer :: c,j,s
	integer (8) :: fishArray(0:8)
	integer (8) :: fishTracker(0:8)

	! Output startup message
	call display_welcome(day,part)

	if (.NOT. file_exists(filename)) stop error1

	call get_fishArray(filename, fishArray)
	fishTracker = 0

	total_fish = sum(fishArray)

	write(*,'(A,I0)') " » Total Lantern fish at start: ",total_fish
	write(*,'(A,I0)') " » Number of daily cycles to model: ",cycles

	! now calculate the number of fish over the 'cycles' period
	do c=1,cycles
		! copy the current fish status to the tracker - excluding 'day 0' which is respawn
		fishTracker(0:7) = fishArray(1:8)
		! copy and add the respawn fish (as exclude above) to 'day 6' position in the tracker
		fishTracker(6) = fishTracker(6) + fishArray(0)
		! copy the same respawn fish amount to 'day 8' of the tracker -> new born fish!
		fishtracker(8) = fishArray(0)
		! upadte the total fish count with any in 'day 8' as they are new borns
		total_fish = total_fish + fishTracker(8)
		! DONE : now reset the 'fishArray' to the newly calculated state ready for next loop
		fishArray = fishTracker
		! Uncomment below to look at per day calculations
		!print *, "Cycles completed: ",c," total fish count: ",total_fish
	end do

	print *, ""
	write(*,'(A,I0)') " » Total Lantern fish created: ",total_fish
	print *, ""

contains

	! Display the AoC puzzle day and part being resolved
	subroutine display_welcome(day,part)
		implicit none
		integer, intent(in) :: day,part
		print *,""
		write (*,'(A,I2.2,A,I2.2)') "AoC 2021 - solution for Day ",day," part ",part
		print *,""
	end subroutine display_welcome

	! Check input filename exists
	function file_exists(filename) result (exists)
		implicit none
		character(len=*), intent(in) :: filename
		logical :: exists ! variable for the return.  NB: no intent(out) needed.

		inquire(file=filename, exist=exists)
	end function file_exists

    ! Read in the list of Lantern fish from puzzle data source file
    subroutine get_fishArray(filename, fishArray)
        character(len=*), intent(in) :: filename
        integer (8), intent(inout) :: fishArray(0:8)
        integer :: fileunit, io, I
        character(len=1) :: A   ! account for ',' separator in in file

 		! ensure array has known state for initial values
 		fishArray = 0

        open(newunit=fileunit, file=filename, action='read', position='rewind')

        do
        	read(fileunit,'(I1,A1)',advance="no",iostat=io) I,A
        	if (io /= 0) exit
        	fishArray(I) = fishArray(I)+1  ! add fish by array index to existing
        end do
        fishArray(I) = fishArray(I)+1

        close(fileunit)

    end subroutine get_fishArray

end program aoc_day06_p1


       FUNC(X)=X*X-5.
       TOLX=1.E-06
       X=1.
       FOLD=FUNC(X)
       DX=.5
       ITER=0

10     CONTINUE
         ITER=ITER+1
         X=X+DX
         PRINT *,ITER,X,SQRT(5.)-X
         IF ((FOLD*FUNC(X)) .LT. 0) THEN
            X=X-DX
            DX=DX/2
         END IF
       IF (ABS(DX) .GT. TOLX) GOTO 10

       STOP
       END