	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
C	CLUSTEST - CLUSTER TESTING PROGRAM
C		   DETERMINES WHETHER CLUSTERS COME FROM DIFFERENT POPULATIONS
C
C
C	REVISION:  A		NEW
C
C
C	ALGORITHM DESIGNER AND PROGRAMMER:	FRANK EVANS      NOVEMBER 1985
C
C	COGNIZANT PROGRAMMER:	KFE
C
C  7-APR-87  ...LWK...  ADDED FIX FOR BYTE-FORMAT USTATS FILES,  FIXED BUG IN
C                      CLUSTER-PAIRS DISTANCE MATRIX.
C
C  5-SEP-94  ...CRS (CRI) .. PORTED TO UNIX
c  5 feb 0   ...lwk...  replaced variable in format statement with internal writes
C
	IMPLICIT  NONE
	INTEGER	  MAXCLUS, MAXDIM, MAXRECSIZ
	PARAMETER ( MAXCLUS = 200 )
	PARAMETER ( MAXDIM = 12 )
	PARAMETER ( MAXRECSIZ = MAXDIM*(MAXDIM+1)/2+MAXDIM+3 )

	INTEGER	UNIT(2), NCLUS(2)
	INTEGER BUFFER(MAXRECSIZ)
	INTEGER	NUMBER(MAXCLUS,2)
	INTEGER FILE, STATUS, NUMFILES, NWORDS, NDIM, COUNT
	INTEGER C, C1,C2, N,M, K,  LEVEL
	INTEGER N1,N2
	INTEGER STARTP, ENDP, NUMP,  NCLUSPAIR, NW1
	REAL*8	MEAN(MAXDIM,MAXCLUS,2), COV(MAXDIM,MAXDIM,MAXCLUS,2)
	REAL	MEANVECT(MAXDIM), XVECTOR(MAXDIM), SIGMA(MAXDIM,MAXDIM)
	REAL	R2 , MAHADIST(MAXCLUS,MAXCLUS)
	REAL	MINMAHA(MAXCLUS), AVGMAHA(MAXCLUS), MINTOT, AVGTOT, MAXTOT
	INTEGER	MINCLUS(MAXCLUS)
	REAL	COMP(MAXDIM), MAXCOMP(MAXDIM)
	REAL	AVGCOMP(MAXDIM)
	REAL	RBUF(MAXRECSIZ), RNDIM
	REAL	MAHAC1, MAHAC2,  X0
	REAL	MAHAMU, MAHAVAR, MU0, U, NOBJ, PHI
	REAL	T2, F, FISH
	LOGICAL	ERROR, CONFID, XVPTST
	CHARACTER*80 STRING
	CHARACTER*72 INPFILES(2)
	CHARACTER*8 INFMT
	character*20 fstrng
	INTEGER TEMPINT
	REAL*8 	RNDOFF
	EQUIVALENCE (RBUF,BUFFER)

	DATA RNDOFF/1000000./
	CALL IFMESSAGE('CLUSTEST version 5-FEB-10')
C--		OPEN THE ONE OR TWO STATISTICS DATASETS
	CALL XVP ('INP', INPFILES, NUMFILES)
	DO FILE = 1,NUMFILES
	    CALL XVUNIT(UNIT(FILE),'INP',FILE,STATUS,' ')
	    CALL XVOPEN(UNIT(FILE),STATUS, 'IO_ACT','SA',
     &       'OPEN_ACT','SA',' ')
	    CALL XVGET(UNIT(FILE),STATUS, 'NL',NCLUS(FILE), 'NS', NWORDS,
     &	     'FORMAT', INFMT,' ')
	    IF (INFMT.EQ.'BYTE') THEN			!FOR USTATS OUTPUT
	      NWORDS = NWORDS/4
	    ELSEIF (INFMT.NE.'FULL') THEN
	      CALL MABEND(' INVALID FILE FORMAT',' ')
	    ENDIF
	    IF (FILE.EQ.1) NW1 = NWORDS
	    IF (FILE.EQ.2) THEN
	      IF (NWORDS.NE.NW1) CALL MABEND(
     &		'INPUT FILES MUST HAVE EQUAL # DIMENSIONS',' ')
	    ENDIF
	ENDDO
	IF (NUMFILES .EQ. 1)   NCLUS(2) = NCLUS(1)

C--		COMPUTE THE NUMBER OF DIMENSIONS FROM THE SIZE OF THE RECORD
C	NWORDS = NDIM*(NDIM+1)/2 + NDIM + 3  =  (NDIM**2 + 3*NDIM + 6)/2
	RNDIM = (SQRT(8.*FLOAT(NWORDS)-15.)-3.)/2.
	NDIM = NINT(RNDIM)

C--		TEST FOR VARIOUS ERROR CONDITIONS
	IF (ABS(RNDIM - NDIM) .GT. 0.001) THEN
	    CALL XVMESSAGE('Not a valid statistics data set record',' ')
	    CALL ABEND
	ENDIF
	IF (NDIM .GT. MAXDIM) THEN
	    CALL XVMESSAGE('Too many dimensions (channels)',' ')
	    CALL ABEND
	ENDIF
	IF (NCLUS(1) .LT. 2  .AND.  NUMFILES .EQ. 1) THEN
	    CALL XVMESSAGE('Must be at least two clusters',' ')
	    CALL ABEND
	ENDIF
	DO FILE = 1, NUMFILES
	    IF (NCLUS(FILE) .GT. MAXCLUS) THEN
	        CALL XVMESSAGE('Too many clusters',' ')
	        CALL ABEND
	    ENDIF
	ENDDO

C--		READ IN THE INFORMATION FROM THE STAT DATASET
C-		  THE NUMBER OF OBJECTS, THE MEAN VECTOR, AND
C-		  THE COVARIANCE MATRIX STORED IN A COMPRESSED FORMAT
	DO FILE = 1,NUMFILES
	  DO C = 1,NCLUS(FILE)
	    CALL XVREAD(UNIT(FILE),BUFFER,STATUS,' ')
	    NUMBER(C,FILE) = BUFFER(3+NDIM)
	    COUNT = 1
	    DO N = 1,NDIM
              TEMPINT = NINT(RBUF(2+N)*RNDOFF)
	      MEAN(N,C,FILE) = DBLE(TEMPINT/RNDOFF)
	      DO M = 1,N
	        TEMPINT = NINT(RBUF(3+NDIM+COUNT)*RNDOFF)
	        COV(M,N,C,FILE) = DBLE(TEMPINT/RNDOFF)
		COV(N,M,C,FILE) = COV(M,N,C,FILE)
		COUNT = COUNT + 1
	      ENDDO
	    ENDDO
	  ENDDO
	  CALL XVCLOSE(UNIT(FILE),STATUS,' ')
	ENDDO

C1101	      FORMAT(A,F18.15,A,F18.15)

C-		FIND OUT HOW MUCH STUFF TO LIST OUT
	CALL XVP('LEVEL',LEVEL,COUNT)

C--		LIST THE INFORMATION IN THE STAT DATASET
	IF (LEVEL .GE. 3) THEN
	  DO FILE = 1, NUMFILES
	    CALL XVMESSAGE(' ',' ')
	    CALL XVMESSAGE(' ',' ')
	    WRITE (STRING,99), 'STATISTICAL SUMMARY FOR FILE',FILE
	    CALL NPRINT (STRING)
	    CALL XVMESSAGE(' ',' ')
	    DO C = 1,NCLUS(FILE)
		WRITE (STRING,101),'CLUSTER: ', C,
     +			 '      NUMBER OF MEMBERS: ',NUMBER(C,FILE)
		CALL NPRINT (STRING)
		IF (LEVEL .GE. 4) THEN
		    CALL XVMESSAGE(' MEAN           STD',' ')
		    DO N = 1,NDIM
			WRITE (STRING,105),MEAN(N,C,FILE),SQRT(COV(N,N,C,FILE))
			CALL NPRINT (STRING)
		    ENDDO
		ENDIF
	    ENDDO
	  ENDDO
	ENDIF
99	FORMAT (A,I2)
101	FORMAT (A,I3,A,I6)
105	FORMAT (E10.3,4X,E10.3)

	CONFID = .NOT. XVPTST('MAHA')

C--
	IF (NUMFILES .EQ. 1) THEN

	    DO  N = 1, NDIM
	        MAXCOMP(N) = -1.0E20
	        AVGCOMP(N) = 0.0
	    ENDDO

C--		GO THROUGH ALL PAIRS OF CLUSTERS
	    DO C1 = 2,NCLUS(1)
	        DO C2 = 1,C1-1

		    N1 = NUMBER(C1,1)
		    N2 = NUMBER(C2,1)
C-			CALCULATE THE VECTOR BETEEN THE MEANS
		    DO N = 1,NDIM
		        MEANVECT(N) = MEAN(N,C1,1) - MEAN(N,C2,1)
		    ENDDO
C-			CALCULATE THE POOLED COVARIANCE MATRIX
		    DO N = 1,NDIM
		        DO M = 1,NDIM
			    SIGMA(M,N) = ( (N1-1)*COV(M,N,C1,1)
     +				     +     (N2-1)*COV(M,N,C2,1) )
     +					 / (N1+N2-2)
		        ENDDO
		    ENDDO

C--			COMPUTE THE INVERSE OF THE POOLED COVARIANCE MATRIX
C-			  TIMES THE MEAN VECTOR
		    CALL GAUSSES( SIGMA, MEANVECT, XVECTOR, NDIM, ERROR )

		    IF (ERROR) THEN
			WRITE (STRING,199), 'CLUSTERS', C1, C2,
     +				'  HAVE TOO SMALL WITHIN GROUP VARIANCE'
199			FORMAT (A,I4,I4,A)
			CALL NPRINT (STRING)
		    ENDIF

C--			DO THE DOT PRODUCT TO GET THE SQUARE OF THE MAHALANOBIS
		    R2  = 0
		    DO  N = 1, NDIM
		        COMP(N) = XVECTOR(N) * MEANVECT(N)
		        R2 = R2 + COMP(N)
		    ENDDO

		    IF (R2 .GE. 0.0 .AND. .NOT. ERROR) THEN
C-				GET SOME INFO ON THE COMPONENTS OF THE MAHA
		        DO  N = 1, NDIM
		            MAXCOMP(N) = MAX(MAXCOMP(N),COMP(N)/R2)
		            AVGCOMP(N) = AVGCOMP(N) + COMP(N)/R2
		        ENDDO
		        NCLUSPAIR = NCLUSPAIR + 1

		        MAHADIST(C1,C2) = SQRT(R2)
C--			    IF DESIRED COMPUTE THE APPROXIMATION TO THE
C-				CONFIDENCE LEVEL
		        IF (CONFID) THEN
C--				FIND THE RELATIVE SIZES OF THE TWO CLUSTERS
C-				  BY CALCULATING THE MAHALANOBIS DISTANCE WITH
C-				  EACH COVARIANCE MATRIX SEPARATELY
			    CALL GAUSSES( COV(1,1,C1,1), MEANVECT,
     +					  XVECTOR, NDIM, ERROR )
			    MAHAC1 = 0.0
			    DO N = 1, NDIM
				MAHAC1 = MAHAC1 + XVECTOR(N)*MEANVECT(N)
			    ENDDO
			    CALL GAUSSES( COV(1,1,C2,1), MEANVECT,
     +					  XVECTOR, NDIM, ERROR )
			    MAHAC2 = 0.0
			    DO N = 1, NDIM
				MAHAC2 = MAHAC2 + XVECTOR(N)*MEANVECT(N)
			    ENDDO
C ABS FUNCTION ADDED TO PREVENT SQRT OF NEGATIVE NUMBER ERROR:
			    MAHAC1 = SQRT(ABS(MAHAC1))
			    MAHAC2 = SQRT(ABS(MAHAC2))
C--				FROM THE FRACTIONAL SIZES OF THE CLUSTERS,
C-				  THE NUMBER OF OBJECTS IN BOTH CLUSTERS,
C-				  AND THE NUMBER OF DIMENSIONS THE CONFIDENCE
C-				  LEVEL IS APPROXIMATED FOR THE UNIFORM
C-				  PROBABILITY DENSITY CASE
			    X0 = MAHAC1/(MAHAC1+MAHAC2)
		  	    NOBJ = N1 + N2
			    MU0 = SQRT(3./ (3.*X0**2 - 3.*X0 + 1) )
			    MAHAMU = MU0 + (25.0/NOBJ)*(NDIM-1)
			    MAHAVAR = 10.0 * NOBJ**(-1.08)
			    U = (MAHADIST(C1,C2) - MAHAMU) / SQRT(MAHAVAR)
			    MAHADIST(C1,C2) = PHI(U)
		        ENDIF
		    ELSE
		        MAHADIST(C1,C2) = -1.0
		    ENDIF
	        ENDDO
	    ENDDO

C--		FILL IN THE OTHER HALF OF THE DISTANCE MATRIX
	    DO C1 = 2,NCLUS(1)
	        DO C2 = 1,C1-1
		    MAHADIST(C2,C1) = MAHADIST(C1,C2)
	        ENDDO
	    ENDDO

	ELSE

C--		IF COMPARING TWO STAT DATASETS THEN COMPARE EACH CLUSTER
C-		    IN FIRST WITH EACH IN SECOND
	    DO C1 = 1,NCLUS(1)
	        DO C2 = 1,NCLUS(2)

		    N1 = NUMBER(C1,1)
		    N2 = NUMBER(C2,2)
		    DO N = 1,NDIM
		        MEANVECT(N) = MEAN(N,C1,1) - MEAN(N,C2,2)
		    ENDDO
		    DO N = 1,NDIM
		        DO M = 1,NDIM
			    SIGMA(N,M) = ( (N1-1)*COV(M,N,C1,1)
     +				     +     (N2-1)*COV(M,N,C2,2) )
     +					   /(N1+N2-2)
		        ENDDO
		    ENDDO

		    CALL GAUSSES( SIGMA, MEANVECT, XVECTOR, NDIM, ERROR )
		    IF (ERROR) THEN
			WRITE (STRING,199), 'CLUSTERS', C1, C2,
     +				'  HAVE TOO SMALL WITHIN GROUP VARIANCE'
			CALL NPRINT (STRING)
		    ENDIF

		    R2  = 0
		    DO  N = 1, NDIM
		        R2 = R2 + XVECTOR(N) * MEANVECT(N)
		    ENDDO

		    IF (R2 .GE. 0.0 .AND. .NOT. ERROR) THEN
			IF (CONFID) THEN
C--				COMPUTE HOTELLINGS T SQUARED STATISTIC
C-				  AND GET THE CONFIDENCE LEVEL FOR IT
			    T2 = R2/( 1./N1 + 1./N2 )
			    F = (N1+N2-NDIM-1) * T2/ ( (N1+N2-2)*NDIM )
			    MAHADIST(C1,C2) = FISH(F, NDIM, N1+N2-NDIM-1)
			ELSE
		 	    MAHADIST(C1,C2) = SQRT(R2)
			ENDIF
		    ELSE
		        MAHADIST(C1,C2) = -1.0
		    ENDIF
	        ENDDO
	    ENDDO

	ENDIF

	IF (LEVEL .GE. 2) THEN
C--			PRINT OUT THE MATRIX IF DESIRED
	    CALL XVMESSAGE(' ',' ')
	    CALL XVMESSAGE(' ',' ')
	    IF (CONFID) THEN
		CALL XVMESSAGE(
     &           'CONFIDENCE LEVELS BETWEEN PAIRS OF CLUSTERS',' ')
	    ELSE
	        CALL XVMESSAGE(
     &            'MAHALANOBIS DISTANCE BETWEEN PAIRS OF CLUSTERS',' ')
	    ENDIF
	    DO STARTP = 1,NCLUS(1),9
		CALL XVMESSAGE(' ',' ')
		CALL XVMESSAGE(' ',' ')
		ENDP = MIN(NCLUS(1),STARTP+9-1)
		NUMP = MIN(9,NCLUS(1)-STARTP+1)
		write(fstrng,109) nump
		WRITE (STRING,fstrng), (K,  K=STARTP,ENDP)
		CALL NPRINT (STRING)
		DO C2 = 1,NCLUS(2)
		    CALL XVMESSAGE(' ',' ')
		    IF (CONFID) THEN
		        write(fstrng,111) nump
			WRITE (STRING,fstrng),C2,(MAHADIST(K,C2),  K=STARTP,ENDP)
		    ELSE
		        write(fstrng,113) nump
			WRITE (STRING,fstrng),C2,(MAHADIST(K,C2),  K=STARTP,ENDP)
		    ENDIF
		    CALL NPRINT (STRING)
		ENDDO
	    ENDDO
c109	    FORMAT ('      ',<NUMP>(I3,5X))
c111	    FORMAT (I3,' :',<NUMP>(F6.3,2X))
c113	    FORMAT (I3,' :',<NUMP>(F6.2,2X))
c  variables in format stmts not supported by new compiler, replaced by
109	    format ('(''      ''',i2,'(I3,5X))')
111	    format ('(I3,'' :''',i2,'(F6.3,2X))')
113	    format ('(I3,'' :''',i2,'(F6.2,2X))')
	ENDIF

	IF (NUMFILES .EQ. 1) THEN

C--			CALCULATE THE MINIMUM AND AVERAGE MAHA OR CONFID LEVEL
	    MINTOT = 1.0E20
	    AVGTOT = 0.0
	    DO C1 = 1,NCLUS(1)
	        MINMAHA(C1) = 1.0E20
	        AVGMAHA(C1) = 0.0
	        DO C2 = 1,NCLUS(1)
		    IF (C1 .NE. C2) THEN
		        MINMAHA(C1) = MIN(MAHADIST(C1,C2),MINMAHA(C1))
		        AVGMAHA(C1) = AVGMAHA(C1) + MAHADIST(C1,C2)
		    ENDIF
	        ENDDO
	        AVGMAHA(C1) = AVGMAHA(C1)/(NCLUS(1)-1)
	        MINTOT = MIN(MINMAHA(C1),MINTOT)
	        AVGTOT = AVGTOT + AVGMAHA(C1)
	    ENDDO
	    AVGTOT = AVGTOT/NCLUS(1)

	    IF (LEVEL .GE. 1) THEN
		CALL XVMESSAGE(' ',' ')
		CALL XVMESSAGE(' ',' ')
	        CALL XVMESSAGE('CLUSTER   MINIMUM   AVERAGE',' ')
	        DO C1 = 1,NCLUS(1)
		    IF (CONFID) THEN
	                WRITE (STRING,116), C1, MINMAHA(C1), AVGMAHA(C1)
			CALL NPRINT (STRING)
		    ELSE
	                WRITE (STRING,117), C1, MINMAHA(C1), AVGMAHA(C1)
			CALL NPRINT (STRING)
		    ENDIF
	        ENDDO
	    ENDIF
116	    FORMAT (' ',I3,' :  ',F6.3,4X,F6.3)
117	    FORMAT (' ',I3,' :  ',F6.2,4X,F6.2)

	    CALL XVMESSAGE (' ',' ')
	    IF (CONFID) THEN
		WRITE (STRING,118), 'OVERALL MINIMUM AND AVERAGE : ',
     +				 MINTOT, AVGTOT
	    ELSE
		WRITE (STRING,119), 'OVERALL MINIMUM AND AVERAGE : ',
     +				 MINTOT, AVGTOT
	    ENDIF
	    CALL NPRINT (STRING)
	    CALL XVMESSAGE(' ',' ')
118	    FORMAT (A,F6.3,3X,F6.3)
119	    FORMAT (A,F6.2,3X,F6.2)

C--			LIST OUT THE MAX AND AVERAGE OF COMPONENTS OF THE MAHA
	    CALL XVMESSAGE(' ',' ')
	    CALL XVMESSAGE(' ',' ')
	    CALL XVMESSAGE(
     &         'COMPONENTS OF THE MAHALANOBIS DISTANCE BY BAND',' ')
	    CALL XVMESSAGE(' ',' ')
	    CALL XVMESSAGE('BAND       MAX    AVERAGE   ',' ')
	    DO N = 1,NDIM
		AVGCOMP(N) = AVGCOMP(N)/NCLUSPAIR
		WRITE (STRING,123), N,MAXCOMP(N),AVGCOMP(N)
		CALL NPRINT (STRING)
	    ENDDO
123		FORMAT(I3,5X,F7.3,2X,F7.3)

	ELSE

	    MINTOT = 1.0E20
	    MAXTOT = -1.0E20
	    DO C1 = 1,NCLUS(1)
	        MINMAHA(C1) = 1.0E20
	        DO C2 = 1,NCLUS(2)
		    IF (MAHADIST(C1,C2) .LT. MINMAHA(C1)) THEN
		        MINMAHA(C1) = MAHADIST(C1,C2)
		        MINCLUS(C1) = C2
		    ENDIF
	        ENDDO
	        MINTOT = MIN(MINMAHA(C1),MINTOT)
	        MAXTOT = MAX(MINMAHA(C1),MAXTOT)
	    ENDDO

	    MINTOT = 1.0E20
	    MAXTOT = -1.0E20
	    DO C1 = 1,NCLUS(1)
	        MINMAHA(C1) = 1.0E20
	        DO C2 = 1,NCLUS(2)
		    IF (MAHADIST(C1,C2) .LT. MINMAHA(C1)) THEN
		        MINMAHA(C1) = MAHADIST(C1,C2)
		        MINCLUS(C1) = C2
		    ENDIF
	        ENDDO
	        MINTOT = MIN(MINMAHA(C1),MINTOT)
	        MAXTOT = MAX(MINMAHA(C1),MAXTOT)
	    ENDDO

	    IF (LEVEL .GE. 1) THEN
		CALL XVMESSAGE(' ',' ')
		CALL XVMESSAGE(' ',' ')
	        CALL XVMESSAGE(
     &                 'CLUSTER      MINIMUM    MIN CLUSTER',' ')
	        DO C1 = 1,NCLUS(1)
		    IF (CONFID) THEN
	 		WRITE (STRING,130), C1,MINMAHA(C1),MINCLUS(C1)
		    ELSE
	 		WRITE (STRING,131), C1,MINMAHA(C1),MINCLUS(C1)
		    ENDIF
		    CALL XVMESSAGE(STRING,' ')
	        ENDDO
	    ENDIF
130	    FORMAT (' ',I3,'    :  ',F6.3,'    : ',I3)
131	    FORMAT (' ',I3,'    :  ',F6.2,'    : ',I3)

	    CALL XVMESSAGE(' ',' ')
	    IF (CONFID) THEN
	        WRITE (STRING,132),
     +			'MINIMUM AND MAXIMUM FOR CLOSEST CLUSTER: ',
     +			 MINTOT,MAXTOT
	    ELSE
	        WRITE (STRING,133),
     +			 'MINIMUM AND MAXIMUM FOR CLOSEST CLUSTER: ',
     +			 MINTOT,MAXTOT
	    ENDIF
	    CALL NPRINT (STRING)
	    CALL XVMESSAGE(' ',' ')
132	    FORMAT (A,F6.3,3X,F6.3)
133	    FORMAT (A,F6.2,3X,F6.2)

	ENDIF

	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE(' ',' ')

	RETURN
	END

	SUBROUTINE NPRINT(STRING)
C    USES XVMESSAGE TO PRINT A STRING BUT DOES NOT PRINT THE EXTRA SPACES AT END
	IMPLICIT NONE
	CHARACTER*(*) STRING
	INTEGER	I

	I = LEN(STRING)
	DO WHILE (STRING(I:I) .EQ. ' ' .AND. I .GT. 0)
	    I = I - 1
	ENDDO

	CALL XVMESSAGE(STRING(1:I),' ')

	RETURN
	END

C     STOLEN FROM VICAR PROGRAM DENDSTAT
	SUBROUTINE GAUSSES (A, Y, X, NCOL, ERROR)
C#######################################################################
C  NAME OF ROUTINE
C     GAUSSES ( GAUSSian Elimination for Symmetric matrix )
C  PURPOSE
C ----- FORTRAN subroutine to solve simultaneous equations
C ----- using Gaussian elimination.
C      special thanks to STEVE ADAMS for supplying this routine's ancestor.
C  ENVIRONMENT
C      VAX 11/780    VMS  with TAE/VICAR1 EXECUTIVE       FORTRAN-77
C  CALLING SEQUENCE
C      Standard subroutine call and return.
C  INPUT AND OUTPUT PARAMETERS
C        This routine solves the equation  y = Ax, where y is a known
C        vector, A is a known symmetric square matrix, and x is the
C        unknown vector.
C
C      A array    - matrix A stored in normal mode.
C      Y array    - vector y.
C      X array    - vector x, the solution.
C      NCOL       - number of rows and columns in A matrix.
C      ERROR      - .TRUE. if no solution obtained. .FALSE. otherwise.
C  CALLED BY
C      MAIN44
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      PARAMETER ( MAXDIM = 12 )          ! MAXIMUM NUMBER OF CHANNELS
C				MUST BE THE SAME AS IN CALLING ROUTINE
	LOGICAL ERROR
	INTEGER NCOL, I, J, N, N1, I1, K, L
	REAL*4  Y(MAXDIM), X(MAXDIM), A(MAXDIM,MAXDIM)
	REAL*4  B(MAXDIM,MAXDIM), W(MAXDIM), BIG, AB,
     &          SUM, T, TEMP
C
C=================START OF EXECUTABLE CODE===============================
C
	ERROR = .FALSE.
	N = NCOL

	DO 20 I = 1, N
	  DO 10 J = 1, N
	    B(I,J) = A(I,J)
10	CONTINUE
	  W(I) = Y(I)
20	CONTINUE
	N1 = N - 1
	DO 80 I = 1, N1
	  BIG = ABS(B(I,I))
	  L = I
	  I1 = I+1
	  DO 30 J = I1, N
	    AB = ABS(B(J,I))
	    IF (AB .LE. BIG) GO TO 30
	      BIG = AB
	      L = J
30	  CONTINUE
	  IF (BIG .EQ. 0.0) GO TO 80
	  IF ( L  .EQ.  I ) GO TO 50
	  DO 40 J = 1, N
            TEMP   = B(L,J)               ! SWAP ROW L AND ROW J.
            B(L,J) = B(I,J)
            B(I,J) = TEMP
40	  CONTINUE
            TEMP   = W(L)
            W(L)   = W(I)
            W(I)   = TEMP
50	  CONTINUE
	  DO 70 J = I1, N
	    T = B(J,I) / B(I,I)
	    DO 60 K = I1, N
	      B(J,K) = B(J,K) - T * B(I,K)
60	    CONTINUE
	    W(J) = W(J) - T * W(I)
70	  CONTINUE
80	CONTINUE

	IF (B(N,N) .EQ. 0.0)   THEN
            ERROR = .TRUE.
            GO TO 110
        END IF

	X(N) = W(N) / B(N,N)
	I = N - 1
C ----- Back substitution.
90	SUM = 0
	  I1 = I+1
	  DO 100 J = I1, N
	    SUM = SUM + B(I,J) * X(J)
100	  CONTINUE

	IF (B(I,I) .EQ. 0.0)   THEN
            ERROR = .TRUE.
            GO TO 110
        END IF

	X(I) = (W(I) - SUM) / B(I,I)
	  I = I - 1
	IF (I .GT. 0) GO TO 90

110     CONTINUE
	RETURN
	END

      FUNCTION ERFF(X,N1)
C ----PURPOSE:  TO COMPUTE THE VALUE OF THE ERROR FUNCTION OR
C     THE STANDARD NORMAL CUMULATIVE DISTRIBUTION FUNCTION
C     AT A GIVEN POINT.
C
C ----CALLING SEQUENCE :  VARIABLE = ERFF(X,N1)
C
C     X     IS THE POINT WHERE THE FUNCTION IS EVALUATED (INPUT)
C
C     N1    =1, IF THE ERROR FUNCTION IS DESIRED.
C           =2, IF THE COMPLIMENTARY ERROR FUNCTION IS DESIRED.
C           =3, IF THE STANDARD NORMAL CUMULATIVE DISTRIBUTION
C           FUNCTION IS DESIRED.
C
C ----RESTRICTIONS AND COMMENTS: NONE.
      REAL ABS,T,V
      GO TO (1,2,3),N1
C
C ----ERF
      ENTRY ERF(X)
    1 N=1
      T=X
      GO TO 4
C
C ----ERFC
      ENTRY ERFC(X)
    2 N=2
      T=X
      GO TO 4
C
C ----PHI
      ENTRY PHI(X)
    3 N=3
      T=X/1.4142136
    4 M=1
      IF(X.LT.0.) M=2
      V=ABS(T)
      U=T*T
C
C ----TEST V
      IF(V-0.5) 10,10,20
C
C ----CASE V.LE.0.5
   10 ERFF= ((0.31665289*U+1.7222758)*U+21.385332)/((U+7.8437457)*U
     1    +18.952257)*T
C
C ----BRANCH TO RETURN THE APPROPRIATE FUNCTION
      GO TO (5,6,7),N
    5 RETURN
    6 ERFF=1.0-ERFF
      RETURN
    7 ERFF=0.5+0.5*ERFF
      RETURN
C
   20 X1=V
      X2=V*V
      X3=V*X2
      X4=X2*X2
C
C ----TEST V
      IF(V-8.0) 25,25,30
C
C ----CASE  V BETWEEN 0.5 AND 8.0 (HART #5703,P 294)
   25 ERFF=EXP(-X2)*(6.1337529+X1*6.1772458+X2*2.8501393+X3*0.56409092)
     1  /  (6.1337546+X1*13.098327+X2*11.497651+X3*5.0472398+X4)
      GO TO 40
C
C ----EXCEPT FOR THE LAST CASE, ERFF=0
   30 ERFF=0.
C
C ----TEST N AND V
      IF((N.NE.2.AND.M.EQ.1).OR.(N.NE.3.AND.M.EQ.2).OR.(V.GT.13.))GOTO40
C
C ----CASE  V BETWEEN 8. AND 13.5 AND ERFC OR PHI(-V) IS DESIRED
C     (HART #5721,P 296)
      ERFF=EXP(-X2)*(0.14845921+X1*0.56418774)/(0.51143728+
     1     X1*0.26277059+X2)
C
C ----BRANCH IF X.LT.0 ,OTHERWISE BRANCH TO RETURN THE
C     APPROPRIATE FUNCTION.
   40 IF(M.GT.1) GO TO 50
      GO TO(41,5,42),N
   41 ERFF=1.0-ERFF
      RETURN
   42 ERFF=0.5-0.5*ERFF+0.5
      RETURN
C
C ----BRANCH TO RETURN THE APPROPRIATE FUNCTION
   50 GO TO (51,52,53),N
   51 ERFF=ERFF-1.0
      ERF=ERFF
      RETURN
   52 ERFF=2.0-ERFF
      ERFC=ERFF
      RETURN
   53 ERFF=0.5*ERFF
      PHI=ERFF
      RETURN
      END
      FUNCTION FISH(F,NN1,NN2)
C
C ----PURPOSE: TO COMPUTE THE CUMULATIVE DISTRIBUTION FUNCTION FOR
C     FISHER F-DISTRIBUTION
C
C ----CALLING SEQUENCE:  VARIABLE = FISH(F,N1,N2)
C     F     THE RATION (U/N1)/(V/N2), WHERE U AND V ARE INDEPENDENT
C           CHI-SQUARE RANDOM VARIABLES WITH N1 AND N2 DEGREES
C           OF FREEDOM, RESPECTIVELY.  (INPUT)
C
C     N1    THE FIRST DEGREES OF FREEDOM, N1.GE.1  (INPUT)
C
C     N2    THE SECOND DEGREES OF FREEDOM, N2.GE.1  (INPUT)
C
C ----RESTRICTIONS AND COMMENTS:  SUBROUTINE ERFF IS REQUIRED TO
C     EVALUATE PHI(X)
      LOGICAL E1,E2,E3
      N1 = NN1
      N2 = NN2
       IF(N1.GE.100.AND.N2.GE.100) GOTO 9
C
C ----INITIALIZATION AND SETTING OF LOGICAL SWITCHES TO .TRUE. IF
C     THE DEGREES OF FREEDOM ARE EVEN
      E1=.FALSE.
      E2=.FALSE.
      E3=.FALSE.
      IF(MOD(N1,2).EQ.0) E1=.TRUE.
      IF(MOD(N2,2).EQ.0) E2=.TRUE.
      X=N2/(N2+N1*F)
      IF(.NOT.(E1.OR.E2)) GO TO 5
      IF(E1.AND..NOT.E2) GO TO 1
      IF(.NOT.E1.AND.E2) GO TO 2
      IF(N1.LE.N2) GO TO 1
C
C ----INITIALIZATION FOR SECOND DEGREE OF FREEDOM EVEN AND LESS THAN
C     FIRST DEGREE OF FREEDOM IF IT TOO IS EVEN
    2 I=N1
      N1=N2
      N2=I
      X=1.0-X
      E3=.TRUE.
C
C ----INITIALIZATION FOR FIRST DEGREE OF FREEDOM EVEN AND LESS THAN
C     SECOND DEGREE OF FREEDOM IF IT IS EVEN
    1 Y=1.0-X
C
C ----CALCULATION OF PROBABILITY FOR AT LEAST ONE DEGREE OF FREEDOM
C     EVEN
      FISH=0.0
      H=SQRT(X**N2)
      M=N1/2
      DO  3 I=1,M
      FISH=FISH+H
    3 H=(H*Y*(N2+2.*(I-1))) / (2.*I)
      IF(E3) GO TO 4
C
C ----ADJUST CALCULATED PROBABILITY IF ITS ONES COMPLEMENT WAS
C     CALCULATED ORIGINALLY
      FISH=1.0-FISH
      RETURN
    4 I=N1
      N1=N2
      N2=I
      RETURN
C
C ----CALCULATION OF THE PROBABILITY FOR BOTH DEGREES OF FREEDOM ODD
    5 Y=1.0-X
      H=.63661977*SQRT(X*Y)
      FISH=.63661977* ACOS(SQRT(X))
      IF(N2.EQ.1) GO TO 8
      M=N2-2
      DO  6  I=1,M,2
      FISH=FISH+H
    6 H=H*X*(I+1)/(I+2)
    8 IF(N1.EQ.1) RETURN
      H=H*N2
      M=N1-2
      DO  7  I=1,M,2
      FISH=FISH-H
    7 H=H*Y*(N2+I)/(I+2)
      RETURN
    9  D1=N1
       D2=N2
       DT=(D1/D2)*F
       DN=SQRT((2.*D2-1.)*DT)-SQRT(2.*D1-1.)
       X=DN/SQRT(1.+DT)
       FISH=PHI(X)
       RETURN
      END


      subroutine fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,
     * iopt,ider,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpu,fpv,
     * nru,nrv,wrk,lwrk)
c  given the set of function values r(i,j) defined on the rectangular
c  grid (u(i),v(j)),i=1,2,...,mu;j=1,2,...,mv, fpopsp determines a
c  smooth bicubic spline approximation with given knots tu(i),i=1,..,nu
c  in the u-direction and tv(j),j=1,2,...,nv in the v-direction. this
c  spline sp(u,v) will be periodic in the variable v and will satisfy
c  the following constraints
c
c     s(tu(1),v) = dr(1) , tv(4) <=v<= tv(nv-3)
c
c     s(tu(nu),v) = dr(4) , tv(4) <=v<= tv(nv-3)
c
c  and (if iopt(2) = 1)
c
c     d s(tu(1),v)
c     ------------ =  dr(2)*cos(v)+dr(3)*sin(v) , tv(4) <=v<= tv(nv-3)
c     d u
c
c  and (if iopt(3) = 1)
c
c     d s(tu(nu),v)
c     ------------- =  dr(5)*cos(v)+dr(6)*sin(v) , tv(4) <=v<= tv(nv-3)
c     d u
c
c  where the parameters dr(i) correspond to the derivative values at the
c  poles as defined in subroutine spgrid.
c
c  the b-spline coefficients of sp(u,v) are determined as the least-
c  squares solution  of an overdetermined linear system which depends
c  on the value of p and on the values dr(i),i=1,...,6. the correspond-
c  ing sum of squared residuals sq is a simple quadratic function in
c  the variables dr(i). these may or may not be provided. the values
c  dr(i) which are not given will be determined so as to minimize the
c  resulting sum of squared residuals sq. in that case the user must
c  provide some initial guess dr(i) and some estimate (dr(i)-step,
c  dr(i)+step) of the range of possible values for these latter.
c
c  sp(u,v) also depends on the parameter p (p>0) in such a way that
c    - if p tends to infinity, sp(u,v) becomes the least-squares spline
c      with given knots, satisfying the constraints.
c    - if p tends to zero, sp(u,v) becomes the least-squares polynomial,
c      satisfying the constraints.
c    - the function  f(p)=sumi=1,mu(sumj=1,mv((r(i,j)-sp(u(i),v(j)))**2)
c      is continuous and strictly decreasing for p>0.
c
c  ..scalar arguments..
      integer ifsu,ifsv,ifbu,ifbv,mu,mv,mr,nu,nv,nuest,nvest,
     * nc,lwrk
      real r0,r1,p,fp
c  ..array arguments..
      integer ider(4),nru(mu),nrv(mv),iopt(3)
      real u(mu),v(mv),r(mr),dr(6),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv),
     * wrk(lwrk),step(2)
c  ..local scalars..
      real res,sq,sqq,sq0,sq1,step1,step2,three
      integer i,id0,iop0,iop1,i1,j,l,lau,lav1,lav2,la0,la1,lbu,lbv,lb0,
     * lb1,lc0,lc1,lcs,lq,lri,lsu,lsv,l1,l2,mm,mvnu,number
c  ..local arrays..
      integer nr(6)
      real delta(6),drr(6),sum(6),a(6,6),g(6)
c  ..function references..
      integer max0
c  ..subroutine references..
c    fpgrsp,fpsysy
c  ..
c  set constant
      three = 3
c  we partition the working space
      lsu = 1
      lsv = lsu+4*mu
      lri = lsv+4*mv
      mm = max0(nuest,mv+nvest)
      lq = lri+mm
      mvnu = nuest*(mv+nvest-8)
      lau = lq+mvnu
      lav1 = lau+5*nuest
      lav2 = lav1+6*nvest
      lbu = lav2+4*nvest
      lbv = lbu+5*nuest
      la0 = lbv+5*nvest
      la1 = la0+2*mv
      lb0 = la1+2*mv
      lb1 = lb0+2*nvest
      lc0 = lb1+2*nvest
      lc1 = lc0+nvest
      lcs = lc1+nvest
c  we calculate the smoothing spline sp(u,v) according to the input
c  values dr(i),i=1,...,6.
      iop0 = iopt(2)
      iop1 = iopt(3)
      id0 = ider(1)
      id1 = ider(3)
      call fpgrsp(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,r,mr,dr,
     * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,
     * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
     * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
      sq0 = 0.
      sq1 = 0.
      if(id0.eq.0) sq0 = (r0-dr(1))**2
      if(id1.eq.0) sq1 = (r1-dr(4))**2
      sq = sq+sq0+sq1
c in case all derivative values dr(i) are given (step<=0) or in case
c we have spline interpolation, we accept this spline as a solution.
      if(sq.le.0.) return
      if(step(1).le.0. .and. step(2).le.0.) return
      do 10 i=1,6
        drr(i) = dr(i)
  10  continue
c number denotes the number of derivative values dr(i) that still must
c be optimized. let us denote these parameters by g(j),j=1,...,number.
      number = 0
      if(id0.gt.0) go to 20
      number = 1
      nr(1) = 1
      delta(1) = step(1)
  20  if(iop0.eq.0) go to 30
      if(ider(2).ne.0) go to 30
      step2 = step(1)*three/(tu(5)-tu(4))
      nr(number+1) = 2
      nr(number+2) = 3
      delta(number+1) = step2
      delta(number+2) = step2
      number = number+2
  30  if(id1.gt.0) go to 40
      number = number+1
      nr(number) = 4
      delta(number) = step(2)
  40  if(iop1.eq.0) go to 50
      if(ider(4).ne.0) go to 50
      step2 = step(2)*three/(tu(nu)-tu(nu-4))
      nr(number+1) = 5
      nr(number+2) = 6
      delta(number+1) = step2
      delta(number+2) = step2
      number = number+2
  50  if(number.eq.0) return
c the sum of squared residulas sq is a quadratic polynomial in the
c parameters g(j). we determine the unknown coefficients of this
c polymomial by calculating (number+1)*(number+2)/2 different splines
c according to specific values for g(j).
      do 60 i=1,number
         l = nr(i)
         step1 = delta(i)
         drr(l) = dr(l)+step1
         call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr,
     *    iop0,iop1,tu,nu,tv,nv,p,c,nc,sum(i),fp,fpu,fpv,mm,mvnu,
     *    wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     *    wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
     *    wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
         if(id0.eq.0) sq0 = (r0-drr(1))**2
         if(id1.eq.0) sq1 = (r1-drr(4))**2
         sum(i) = sum(i)+sq0+sq1
         drr(l) = dr(l)-step1
         call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr,
     *    iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu,
     *    wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     *    wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
     *    wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
         if(id0.eq.0) sq0 = (r0-drr(1))**2
         if(id1.eq.0) sq1 = (r1-drr(4))**2
         sqq = sqq+sq0+sq1
         drr(l) = dr(l)
         a(i,i) = (sum(i)+sqq-sq-sq)/step1**2
         if(a(i,i).le.0.) go to 110
         g(i) = (sqq-sum(i))/(step1+step1)
  60  continue
      if(number.eq.1) go to 90
      do 80 i=2,number
         l1 = nr(i)
         step1 = delta(i)
         drr(l1) = dr(l1)+step1
         i1 = i-1
         do 70 j=1,i1
            l2 = nr(j)
            step2 = delta(j)
            drr(l2) = dr(l2)+step2
            call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr,
     *       iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu,
     *       wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     *       wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
     *       wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
            if(id0.eq.0) sq0 = (r0-drr(1))**2
            if(id1.eq.0) sq1 = (r1-drr(4))**2
            sqq = sqq+sq0+sq1
            a(i,j) = (sq+sqq-sum(i)-sum(j))/(step1*step2)
            drr(l2) = dr(l2)
  70     continue
         drr(l1) = dr(l1)
  80  continue
c the optimal values g(j) are found as the solution of the system
c d (sq) / d (g(j)) = 0 , j=1,...,number.
  90  call fpsysy(a,number,g)
      do 100 i=1,number
         l = nr(i)
         dr(l) = dr(l)+g(i)
 100  continue
c we determine the spline sp(u,v) according to the optimal values g(j).
 110  call fpgrsp(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,r,mr,dr,
     * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,
     * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0),
     * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv)
      if(id0.eq.0) sq0 = (r0-dr(1))**2
      if(id1.eq.0) sq1 = (r1-dr(4))**2
      sq = sq+sq0+sq1
      return
      end


! ============================================================================
!  Reimann Solver for the two-layer shallow water equations
! ============================================================================
subroutine rp1(maxmx,meqn,mwaves,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)

    use parameters_module

    implicit none

    ! Input arguments
    integer, intent(in) :: maxmx,meqn,mwaves,mbc,mx

    double precision, intent(in), dimension(1-mbc:maxmx+mbc, meqn) :: ql,qr
    double precision, intent(in), dimension(1-mbc:maxmx+mbc, *) :: auxl,auxr

    ! Output arguments
    double precision, intent(out) :: s(1-mbc:maxmx+mbc, mwaves)
    double precision, intent(out) :: fwave(1-mbc:maxmx+mbc, meqn, mwaves)
    double precision, intent(out), dimension(1-mbc:maxmx+mbc, meqn) :: amdq,apdq

    ! Local storage
    integer :: i,j,m,mw
    double precision :: eig_vec(4,4),delta(4),alpha(4),beta(4)
    double precision, dimension(4) :: flux_l,flux_r
    double precision, dimension(2) :: h_l,u_l,hu_l,h_r,u_r,hu_r,h_ave,u_ave
    double precision :: b_l,b_r,gamma_l,gamma_r,tau,w_l,w_r
    double precision :: wind_speed,lambda(4),eta_l(2),eta_r(2),h_hat_l(2),h_hat_r(2)
    logical :: dry_state_l(2), dry_state_r(2), inundation

    integer :: layer_index
    double precision :: momentum_transfer(2),flux_transfer_r,flux_transfer_l
    double precision :: inundation_height(2),lambda_l,lambda_r,lambda_hat

    integer :: trans_wave(2-mbc:mx+mbc)
    double precision :: wave_correction(2-mbc:mx+mbc)

    ! Function interfaces
    interface
        function eval_lapack_solve(eig_vec,delta) result(beta)
            implicit none
            double precision, intent(in) :: eig_vec(4,4), delta(4)
            double precision :: beta(4)
        end function eval_lapack_solve
    end interface

    ! Common block
    double precision :: dt,dx,t
    common /comxt/ dt,dx,t

    ! Initialize return variables
    amdq = 0.d0
    apdq = 0.d0

    !          |          |
    !          |          |
    !          |          |
    !----------|----------|----------
    !    i-1         i         i+1
    !  qr(i-1)  ql(i)
    !     Riemann problem at i-1/2 is between qr(i-1) (left state) and ql(i)
    !     (right state)
    do i=2-mbc,mx+mbc
        inundation = .false.
        dry_state_l = .false.
        dry_state_r = .false.

        ! These state variables are the actual depth and momenta
        do j=1,2
            layer_index = 2*(j-1)
            h_l(j) = qr(i-1,layer_index+1) / rho(j)
            h_r(j) = ql(i,layer_index+1) / rho(j)
            hu_l(j) = qr(i-1,layer_index+2) / rho(j)
            hu_r(j) = ql(i,layer_index+2) / rho(j)

            h_hat_l(j) = auxr(i-1,j+2)
            h_hat_r(j) = auxl(i,j+2)

            ! Check for dry states in this layer
            if (h_l(j) < dry_tolerance) then
                dry_state_l(j) = .true.
                h_l(j) = 0.d0
                u_l(j) = 0.d0
            else
                u_l(j) = qr(i-1,layer_index+2) / qr(i-1,layer_index+1)
            endif
            if (h_r(j) < dry_tolerance) then
                dry_state_r(j) = .true.
                h_r(j) = 0.d0
                u_r(j) = 0.d0
            else
                u_r(j) = ql(i,layer_index+2) / ql(i,layer_index+1)
            endif
        enddo

        h_ave = 0.5d0 * (h_l(:) + h_r(:))

        b_l = auxr(i-1,1)
        b_r = auxl(i,1)
        w_l = auxr(i-1,2)
        w_r = auxl(i,2)

        ! ====================================================================
        ! Solve Single layer problem seperately
        if (dry_state_r(2).and.dry_state_l(2)) then
            call single_layer_eigen(h_l,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
            s(i,:) = lambda

            delta(1) = rho(1) * (hu_r(1) - hu_l(1))
            flux_r(2) = rho(1) * (h_r(1) * u_r(1)**2 + 0.5d0 * g * h_r(1)**2)
            flux_l(2) = rho(1) * (h_l(1) * u_l(1)**2 + 0.5d0 * g * h_l(1)**2)
            delta(2) = flux_r(2) - flux_l(2) + g * rho(1) * h_ave(1) * (b_r - b_l)

            beta(1) = (delta(1)*s(i,4)-delta(2)) / (s(i,4)-s(i,1))
            beta(2) = 0.d0
            beta(3) = 0.d0
            beta(4) = (delta(2) - s(i,1)*beta(1)) / s(i,4)

            ! Calculate waves
            forall(mw=1:4)
                fwave(i,:,mw) = eig_vec(:,mw) * beta(mw)
            end forall
            cycle
        endif

        ! ====================================================================
        ! Calculate eigen-space values
        ! ====================================================================

        ! ====================================================================
        ! Inundation cases
        if (dry_state_r(2).and.(.not.dry_state_l(2)).and.(h_l(2) + b_l > b_r)) then
            print *,"Right inundation problem"
            inundation = .true.
            if (inundation_method == 0) then
                stop "Inundation not allowed."
            else if (inundation_method == 1) then
                ! Linear eigensystem
                inundation_height = [h_r(1),0.d0]
                call linear_eigen(h_l,inundation_height,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda

                ! Corrective wave
                s(i,3) = u_l(2) + 2.d0 * sqrt(g*(1.d0-r)*h_l(2))
                s(i,4) = u_r(1) + sqrt(g*h_r(1))
                alpha(3) = r * g * h_l(2) / ((s(i,3) - u_l(2))**2 - g * h_l(2))
                alpha(4) = 0.d0

                eig_vec(1,3:4) = 1.d0
                eig_vec(2,3:4) = s(i,3:4)
                eig_vec(3,3:4) = alpha(3:4)
                eig_vec(4,3:4) = s(i,3:4)*alpha(3:4)
            else if (inundation_method == 2) then
                inundation_height = [h_r(1),dry_tolerance]
                h_r(2) = dry_tolerance
                call linear_eigen(h_l,inundation_height,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda

!                 s(i,4) = u_r(1) + sqrt(g*h_r(1))
!                 eig_vec(:,4) = [1.d0,s(i,4),0.d0,0.d0]
            else if (inundation_method == 3) then
                inundation_height = [h_r(1),dry_tolerance]
                call velocity_eigen(h_l,inundation_height,u_l,u_r,b_l,b_r,lambda,eig_vec)
                s(i,:) = lambda

                ! Correction for fast wave
                s(i,4) = u_r(1) + sqrt(g*h_r(1))
                eig_vec(:,4) = [1.d0,s(i,4),0.d0,0.d0]
            else if (inundation_method == 4) then
                inundation_height = [h_r(1),dry_tolerance]
                call lapack_eigen(h_l,inundation_height,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda

                ! Correction for the fast waves
                s(i,2) = u_r(1) + sqrt(g*h_r(1))
                eig_vec(:,2) = [1.d0,s(i,2),0.d0,0.d0]
            else if (inundation_method == 5) then
                inundation_height = [h_r(1),0.d0]
                call lapack_eigen(h_l,inundation_height,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda
            endif
        else if (dry_state_l(2).and.(.not.dry_state_r(2)).and.(h_r(2) + b_r > b_l)) then
            print *,"Left inundation problem"
            inundation = .true.
            ! Inundation problem eigen
            if (inundation_method == 0) then
                stop "Inundation not allowed."
            else if (inundation_method == 1) then
                ! Linear eigensystem
                inundation_height = [h_l(1),dry_tolerance]
                call linear_eigen(inundation_height,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda

                ! Corrections to internal wave
                s(i,2) = u_r(2) - 2.d0 * sqrt(g*(1.d0-r)*h_r(2))
                alpha(2) = r * g * h_r(2) / ((s(i,2) - u_r(2))**2 - g * h_r(2))
                eig_vec(:,2) = [1.d0,s(i,2),alpha(2),alpha(2)*s(i,2)]

                ! Correction for the fast waves
                s(i,1) = u_l(1) - sqrt(g*h_l(1))
                eig_vec(:,1) = [1.d0,s(i,1),0.d0,0.d0]
            else if (inundation_method == 2) then
                ! Use linearized eigensystem
                inundation_height = [h_l(1),dry_tolerance]
                call linear_eigen(inundation_height,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda

                ! Correction for the fast waves
                s(i,1) = u_l(1) - sqrt(g*h_l(1))
                eig_vec(:,1) = [1.d0,s(i,1),0.d0,0.d0]
            else if (inundation_method == 3) then
                ! Use velocity difference expansion eigensystems
                inundation_height = [h_l(1),dry_tolerance]
                call velocity_eigen(inundation_height,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda

                ! Correction for the fast waves
                s(i,1) = u_r(1) - sqrt(g*h_r(1))
                eig_vec(:,1) = [1.d0,s(i,1),0.d0,0.d0]
            else if (inundation_method == 4) then
                ! LAPACK solver with corrective wave and small wet layer
                inundation_height = [h_r(1),dry_tolerance]
                call lapack_eigen(h_l,inundation_height,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda

                ! Correction for the fast waves
                s(i,1) = u_l(1) - sqrt(g*h_l(1))
                eig_vec(:,1) = [1.d0,s(i,1),0.d0,0.d0]
            else if (inundation_method == 5) then
                ! Use the LAPACK solver with no correction
                inundation_height = [h_l(1),0.d0]
                call lapack_eigen(inundation_height,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda
            endif

        ! ====================================================================
        !  Wall or wet case
        else
            ! Wall dry state or completely wet case
            if (eigen_method == 1) then
                call linear_eigen(h_hat_l,h_hat_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda
            else if (eigen_method == 2) then
                call linear_eigen(h_l,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda
            else if (eigen_method == 3) then
                call velocity_eigen(h_l,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                s(i,:) = lambda
            else if (eigen_method == 4) then
                if (dry_state_r(2).and.(.not.dry_state_l(2)).or. &
                        dry_state_l(2).and.(.not.dry_state_r(2))) then
                    call linear_eigen(h_l,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                    s(i,:) = lambda
                else
                    call lapack_eigen(h_l,h_r,u_l,u_r,b_l,b_r, &
                              &     trans_wave(i),wave_correction(i),lambda,eig_vec)
                    s(i,:) = lambda
                endif
            else
                stop "Invalid eigensystem method requested, method = (1,4)."
            endif
        endif

        !  end of eigenspace calculation
        ! ====================================================================

        ! ====================================================================
        ! Calculate flux vector to be projected onto e-space
        ! Calculate jumps in fluxes
        if (dry_state_r(2).and.(.not.dry_state_l(2)).and.(.not.inundation)) then
            ! Wall boundary conditions
            h_r(2) = h_l(2)
            hu_r(2) = -hu_l(2)
            u_r(2) = -u_l(2)

            ! Top layer eta(2) = b_r - h_l(2) - b_l
            momentum_transfer(1) = g * rho(1) * h_ave(1) * (b_r - h_l(2) - b_l)

            momentum_transfer(2) = 0.d0
            flux_transfer_r = 0.d0
            flux_transfer_l = 0.d0
        ! Left state dry, right wet
        else if (dry_state_l(2).and.(.not.dry_state_r(2)).and.(.not.inundation)) then
            ! Wall boundary conditions
            h_l(2) = h_r(2)
            hu_l(2) = -hu_r(2)
            u_l(2) = -u_r(2)

            ! Top layer eta(2) = h_r(2) + b_r - b_l
            momentum_transfer(1) = g * rho(1) * h_ave(1) * (b_r + h_r(2) - b_l)

            momentum_transfer(2) = 0.d0
            flux_transfer_r = 0.d0
            flux_transfer_l = 0.d0
        ! Fully wet bottom layer or inundation
        else
            momentum_transfer(1) =   g * rho(1) * h_ave(1) * (h_r(2) - h_l(2) + b_r - b_l)
            momentum_transfer(2) = - g * rho(1) * h_ave(1) * (h_r(2) - h_l(2)) + g * rho(2) * h_ave(2) * (b_r - b_l)
            ! Bottom layer momentum transfer flux
            flux_transfer_r = g * rho(1) * product(h_r)
            flux_transfer_l = g * rho(1) * product(h_l)
        endif

        ! Flux jumps
        do j=1,2
            layer_index = 2*(j-1)
            flux_r(layer_index+1) = rho(j) * hu_r(j)
            flux_r(layer_index+2) = rho(j) * (h_r(j) * u_r(j)**2 + 0.5d0 * g * h_r(j)**2)

            flux_l(layer_index+1) = rho(j) * hu_l(j)
            flux_l(layer_index+2) = rho(j) * (h_l(j) * u_l(j)**2 + 0.5d0 * g * h_l(j)**2)
        enddo

        delta = flux_r - flux_l

        ! Bottom layer additional flux
        delta(4) = delta(4) + flux_transfer_r - flux_transfer_l

        ! Momentum source term from layers
        delta(2) = delta(2) + momentum_transfer(1)
        delta(4) = delta(4) + momentum_transfer(2)

        ! Wind forcing
        wind_speed = 0.5d0 * (w_l + w_r)
        tau = wind_drag(wind_speed) * rho_air * wind_speed
        delta(2) = delta(2) - tau * wind_speed

        ! ====================================================================
        ! Solve system, solution is stored in delta
        beta = eval_lapack_solve(eig_vec,delta)

        ! Calculate waves
        forall(mw=1:4)
            fwave(i,:,mw) = eig_vec(:,mw) * beta(mw)
        end forall
    enddo

    ! Calculate amdq and apdq
    ! No entropy fix requested
    if (.not.entropy_fix) then
        do i=2-mbc,mx+mbc
            do mw=1,mwaves
                if (s(i,mw) > 0.d0) then
                    apdq(i,:) = apdq(i,:) + fwave(i,:,mw)
                else
                    amdq(i,:) = amdq(i,:) + fwave(i,:,mw)
                endif
            enddo
        enddo
    else
        do i=2-mbc,mx+mbc
            ! Check to see if an entropy fix is necessary
            if (trans_wave(i) /= 0) then
                print *,"Entropy fix needed: i=",i
                print *,"  s(i,:)=",(s(i,m),m=1,4)
                print *,"  trans_wave=",trans_wave(i)
                print *,"  beta =",wave_correction(i)
                do mw=1,trans_wave(i)-1
                    amdq(i,:) = amdq(i,:) + fwave(i,:,mw)
                enddo
                amdq(i,:) = amdq(i,:) + wave_correction(i) * fwave(i,:,trans_wave(i))
                apdq(i,:) = apdq(i,:) + (1.d0 - wave_correction(i)) * fwave(i,:,trans_wave(i))
                do mw=trans_wave(i)+1,mwaves
                    apdq(i,:) = apdq(i,:) + fwave(i,:,mw)
                enddo
            else
                ! No entropy fix needed
                do mw=1,mwaves
                    if (s(i,mw) > 0.d0) then
                        apdq(i,:) = apdq(i,:) + fwave(i,:,mw)
                    else
                        amdq(i,:) = amdq(i,:) + fwave(i,:,mw)
                    endif
                enddo
            endif
        enddo
    endif
end subroutine rp1
! ============================================================================

! ============================================================================
!  Eigenvalue routines
! ============================================================================

! ============================================================================
!  Eigenspace reconstruction using linear approximation
subroutine linear_eigen(h_l,h_r,u_l,u_r,b_l,b_r,            &
                         &  transonic_wave,wave_correction,s,eig_vec)

    use parameters_module, only: r,g,dry_tolerance,entropy_fix

    implicit none

    ! I/O
    double precision, intent(in) :: h_l(2),h_r(2),u_l(2),u_r(2),b_l,b_r

    integer, intent(inout) :: transonic_wave
    double precision, intent(inout) :: wave_correction
    double precision, intent(inout) :: s(4),eig_vec(4,4)

    ! Locals
    integer :: mw
    double precision :: alpha(4),speeds(4,2),gamma_l,gamma_r
    double precision :: h_ave(2),u_ave(2)
    double precision :: s_l(4),s_r(4),s_ave(4),work_vec(4,4)

    gamma_l = h_l(2) / h_l(1)
    gamma_r = h_r(2) / h_r(1)

    ! Left state alphas
    alpha(1) = 0.5d0*(gamma_l-1.d0+sqrt((gamma_l-1.d0)**2+4.d0*r*gamma_l))
    alpha(2) = 0.5d0*(gamma_l-1.d0-sqrt((gamma_l-1.d0)**2+4.d0*r*gamma_l))
    ! Right state alphas
    alpha(3) = 0.5d0*(gamma_r-1.d0-sqrt((gamma_r-1.d0)**2+4.d0*r*gamma_r))
    alpha(4) = 0.5d0*(gamma_r-1.d0+sqrt((gamma_r-1.d0)**2+4.d0*r*gamma_r))

    ! Left state speeds
    speeds(1,1) = u_l(1) - sqrt(g*h_l(1)*(1+alpha(1)))
    speeds(2,1) = u_l(2) - sqrt(g*h_l(1)*(1+alpha(2)))
    speeds(3,1) = u_l(2) + sqrt(g*h_l(1)*(1+alpha(2)))
    speeds(4,1) = u_l(1) + sqrt(g*h_l(1)*(1+alpha(1)))

    ! Right state speeds
    speeds(1,2) = u_r(1) - sqrt(g*h_r(1)*(1+alpha(4)))
    speeds(2,2) = u_r(2) - sqrt(g*h_r(1)*(1+alpha(3)))
    speeds(3,2) = u_r(2) + sqrt(g*h_r(1)*(1+alpha(3)))
    speeds(4,2) = u_r(1) + sqrt(g*h_r(1)*(1+alpha(4)))

    ! Determine wave speeds
    transonic_wave = 0
    wave_correction = 0.d0
    if (entropy_fix) then
        transonic_wave = 0
        wave_correction = 0.d0
        do mw=1,4
            ! Both speeds right going
            if (speeds(mw,1) > 0.d0) then
                s(mw) = speeds(mw,2)
            ! Transonic rarefaction
            ! s_l < 0.0 < s_r
            else if (speeds(mw,2) > 0.d0) then
                ! Assign base speed for rarefaction, should approximate true speed
                s(mw) = 0.5d0 * sum(speeds(mw,:))
                transonic_wave = mw
                wave_correction = abs(speeds(mw,1)) / (abs(speeds(mw,1)) + abs(speeds(mw,2)))
            else
                s(mw) = speeds(mw,1)
            endif
        enddo
    else
        s(:) = [speeds(1,1),speeds(2,1),speeds(3,2),speeds(3,2)]
    endif

    eig_vec(1,:) = 1.d0
    eig_vec(2,:) = s(:)
    eig_vec(3,:) = alpha
    eig_vec(4,:) = s(:)*alpha(:)

end subroutine linear_eigen
! ============================================================================

! ============================================================================
!  Eigenspace reconstruction using the velocity difference expansion
subroutine velocity_eigen(h_l,h_r,u_l,u_r,b_l,b_r,            &
                         &  transonic_wave,wave_correction,s,eig_vec)

    use parameters_module, only: r,g,one_minus_r

    implicit none

    ! I/O
    double precision, intent(in) :: h_l(2),h_r(2),u_l(2),u_r(2),b_l,b_r

    integer, intent(inout) :: transonic_wave
    double precision, intent(inout) :: wave_correction
    double precision, intent(inout) :: s(4),eig_vec(4,4)
    ! Locals
    double precision :: total_depth_l,total_depth_r,mult_depth_l,mult_depth_r
    double precision :: alpha(4)

    total_depth_l = sum(h_l)
    total_depth_r = sum(h_r)
    mult_depth_l = product(h_l)
    mult_depth_r = product(h_r)

    s(1) = (h_l(1)*u_l(1)+h_l(2)*u_l(2)) / total_depth_l &
          - sqrt(g*total_depth_l)
    s(2) = (h_l(2)*u_l(1)+h_l(1)*u_l(2)) / total_depth_l &
          - sqrt(g*one_minus_r*mult_depth_l/total_depth_l &
          * (1-(u_l(1)-u_l(2))**2/(g*one_minus_r*total_depth_l)))
    s(3) = (h_r(2)*u_r(1)+h_r(1)*u_r(2)) / total_depth_r &
          + sqrt(g*one_minus_r*mult_depth_r/total_depth_r &
          * (1-(u_r(1)-u_r(2))**2/(g*one_minus_r*total_depth_r)))
    s(4) = (h_r(1)*u_r(1)+h_r(2)*u_r(2)) / total_depth_r &
            + sqrt(g*total_depth_r)

    ! Determine wave speeds
    transonic_wave = 0
    wave_correction = 0.d0

    alpha(1:2) = ((s(1:2) - u_l(1))**2 - g * h_l(1)) / (g*h_l(1))
    alpha(3:4) = ((s(3:4) - u_r(1))**2 - g * h_r(1)) / (g*h_r(1))

    eig_vec(1,:) = 1.d0
    eig_vec(2,:) = s(:)
    eig_vec(3,:) = alpha
    eig_vec(4,:) = s(:)*alpha(:)

end subroutine velocity_eigen
! ============================================================================

! ============================================================================
!  Eigenspace reconstruction using LAPACK
subroutine lapack_eigen(h_l,h_r,u_l,u_r,b_l,b_r,            &
                         &  transonic_wave,wave_correction,s,eig_vec)

    use parameters_module, only: entropy_fix

    implicit none

    ! I/O
    double precision, intent(in) :: h_l(2),h_r(2),u_l(2),u_r(2),b_l,b_r

    integer, intent(inout) :: transonic_wave
    double precision, intent(inout) :: wave_correction
    double precision, intent(inout) :: s(4),eig_vec(4,4)

    ! Local
    integer :: j
    double precision :: h_ave(2),u_ave(2)
    double precision :: s_l(4),s_r(4),vec_work(4,4)

    ! Solve eigenvalue problem
    h_ave(:) = 0.5d0 * (h_l(:) + h_r(:))
    u_ave(:) = 0.5d0 * (u_l(:) + u_r(:))
    call eval_lapack_eigen(h_ave,u_ave,s,eig_vec)

    transonic_wave = 0
    wave_correction = 0.d0

    if (entropy_fix) then
        ! Check to see if we may be at a transonic rarefaction
        call eval_lapack_eigen(h_l,u_l,s_l,vec_work)
        call eval_lapack_eigen(h_r,u_r,s_r,vec_work)

        ! Check each wave for a transonic problem
        do j=1,4
            if (s_l(j) < 0.d0 .and. 0.d0 < s_r(j)) then
                print *,"Transonic wave detected in wave family ",j,"."
                transonic_wave = j
                wave_correction = (s_l(j) - s(j)) / (s_l(j) - s_r(j))
            endif
        enddo
    endif

end subroutine lapack_eigen
! ============================================================================

! ============================================================================
! Single layer eigenspace reconstruction
subroutine single_layer_eigen(h_l,h_r,u_l,u_r,b_l,b_r,            &
                         &  transonic_wave,wave_correction,s,eig_vec)

    use parameters_module, only: g

    implicit none

    ! I/O
    double precision, intent(in) :: h_l(2),h_r(2),u_l(2),u_r(2),b_l,b_r

    integer, intent(inout) :: transonic_wave
    double precision, intent(inout) :: wave_correction
    double precision, intent(inout) :: s(4),eig_vec(4,4)

    transonic_wave = 0
    wave_correction = 0.d0

    s(1) = u_l(1) - sqrt(g*h_l(1))
    s(2) = 0.d0
    s(3) = 0.d0
    s(4) = u_r(1) + sqrt(g*h_r(1))

    eig_vec(1,:) = 1.d0
    eig_vec(2,:) = s(:)
    eig_vec(3,:) = 0.d0
    eig_vec(4,:) = 0.d0

end subroutine single_layer_eigen
! ============================================================================

! ============================================================================
!  Helper routines
! ============================================================================

! ============================================================================
!  Evaluate eigenvalues using LAPACK's DGEEV function
subroutine eval_lapack_eigen(h,u,lambda,vec)

    use parameters_module, only: r,g

    implicit none
    double precision, intent(in) :: h(2),u(2)
    double precision, intent(inout) :: lambda(4),vec(4,4)

    integer, parameter :: lwork = 16
    integer :: info
    double precision :: A(4,4),real_lambda(4),imaginary_lambda(4)
    double precision :: empty,work(1,lwork)

    ! Quasi-linear matrix
    A(1,:) = [0.d0,1.d0,0.d0,0.d0]
    A(2,:) = [-u(1)**2 + g*h(1),2.d0*u(1),g*h(1),0.d0]
    A(3,:) = [0.d0,0.d0,0.d0,1.d0]
    A(4,:) = [g*r*h(2),0.d0,-u(2)**2 + g*h(2),2.d0*u(2)]

    ! Call LAPACK eigen solver
    call dgeev('N','V',4,A,4,real_lambda,imaginary_lambda,empty,1,vec,4,work,lwork,info)
    if (info < 0) then
        info = -info
        print "(a,i1,a)","The ",info,"th argument had an illegal value."
        stop
    else if (info > 0) then
        print "(a)","The QR algorithm failed to compute all the"
        print "(a)","eigenvalues, and no eigenvectors have been"
        print "(a,i1,a)","computed; elements",info,"+1:4 of WR and WI"
        print "(a)","contain eigenvalues which have converged."
        stop
    endif
    ! Only need to check if there is a positive imaginary eigenvalue as they
    ! should come in pairs
    if (any(imaginary_lambda > 0.d0)) then
        print "(a,4d16.8)","Imaginary eigenvalues computed: ",imaginary_lambda
        stop
    endif

end subroutine eval_lapack_eigen
! ============================================================================

! ============================================================================
!  Solve R beta = delta using LAPACK's DGESV function
function eval_lapack_solve(eig_vec,delta) result(beta)

    implicit none

    ! Matrix and RHS
    double precision, intent(in) :: eig_vec(4,4), delta(4)

    ! Output
    double precision :: beta(4)

    ! Local storage
    double precision :: R(4,4)
    integer :: ipiv(4),info,i,m

    ! Move input data into work arrays
    R = eig_vec
    beta = delta

    ! Call LAPACK dense linear solver
    call dgesv(4,1,R,4,ipiv,beta,4,info)
    if (.not.(info == 0)) then
        print *, "Error solving R beta = delta, ",info
        print *, "  R=",(eig_vec(1,m),m=1,4)
        do i=2,4
            print *, "    ",(eig_vec(i,m),m=1,4)
        enddo
        print *, "  delta=",(delta(m),m=1,4)
        stop
    endif

end function eval_lapack_solve
! ============================================================================


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of IBITS exhaustively over POS/LEN ranges
module m1
  implicit integer(a-z)
  integer, parameter :: res1(*) = [((ibits(not(0),pos,len),len=0,31-pos),pos=0,31)]
  integer, parameter :: expect1(*) = [((maskr(len),len=0,31-pos),pos=0,31)]
  logical, parameter :: test1 = all(res1 == expect1)
  logical, parameter :: test2 = all([((ibits(0,pos,len),len=0,31-pos),pos=0,31)] == 0)
  integer, parameter :: mess = z'a5a55a5a'
  integer, parameter :: res3(*) = [((ibits(mess,pos,len),len=0,31-pos),pos=0,31)]
  integer, parameter :: expect3(*) = [((iand(shiftr(mess,pos),maskr(len)),len=0,31-pos),pos=0,31)]
  logical, parameter :: test3 = all(res3 == expect3)
end module


CS    REAL FUNCTION BESEK0(X)
      DOUBLE PRECISION FUNCTION BESEK0(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order zero
C   multiplied by the Exponential function, for arguments
C   0.0 .LT. ARG.
C
C  Authors: W. J. Cody and Laura Stoltz
C
C  Latest Modification: March 14, 1992
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION
     1    X, RESULT
C--------------------------------------------------------------------
      JINT = 2
      CALL CALCK0(X,RESULT,JINT)
      BESEK0 = RESULT
      RETURN
C---------- Last line of BESEK0 ----------
      END


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

program character_minmax
  parameter(N=11)
  character(len=*), parameter :: s = MIN ("a", "0", "C")
  character(len=*), parameter :: t = MAX ("a", "0", "C")
  character(len=*), parameter :: u(3) = (/"a", "0", "C"/)
  character*2, parameter ::  kkmin(2) = min((/"za","bb"/), (/"jj","dd"/))
  character*2, parameter ::  kkmax(2) = max((/"za","bb"/), (/"jj","dd"/))
!  character*2, parameter ::  kkmin(2) = (/"za","bb"/)
!  character*2, parameter ::  kkmax(2) = (/"jj","dd"/)
  character*2 tt
  integer result(N),expect(N)

  real,    allocatable :: a(:)
  logical, allocatable :: m(:)
  expect = 1
  result = 1

  if (s /= "0") then
     result(1) = 0
  end if
  if (t /= "a") then
     result(2) = 0
  end if
  if (MINVAL (u) /= s) then
     result(3) = 0
  end if
  if (MAXVAL (u) /= t) then
     result(4) = 0
  end if
  if (MINLOC (u,1) /= 2) then
     result(5) = 0
  end if
  if (MAXLOC (u,1) /= 1) then
     result(6) = 0
  end if
!  if (kkmin(1) /= "jj") then
!     result(7) = 0
!  end if

  tt = kkmin(1)
  if (tt /= "jj") then
     result(7) = 0
  end if
  tt = kkmin(2)
  if (tt /= "bb") then
     result(8) = 0
  end if

   tt = kkmax(1)
  if (tt /= "za") then
     result(9) = 0
  end if

   tt = kkmax(2)
  if (tt /= "dd") then
     result(10) = 0
  end if

  allocate (a(0), m(0))

  if (any ( (/ &
       minloc ( a ), &
       minloc ( a, mask=m ), &
       minloc ( (/ 1   /), mask=(/ .false. /) ), &
       minloc ( (/ 1.0 /), mask=(/ .false. /) ), &
       minloc ( (/ "A" /), mask=(/ .false. /) ), &
       maxloc ( (/ 1   /), mask=(/ .false. /) )  &
       /) /= 0)) then
     result(11) = 0
  end if

  call check(result,expect,N)

end


PROGRAM test_running_average
!
!  Purpose:
!    To test running average subroutine.
!
IMPLICIT NONE

! Declare variables:
INTEGER :: istat              ! I/O status
REAL :: ave                   ! Average
REAL :: std_dev               ! Standard deviation
INTEGER :: nvals              ! Number of values
REAL :: x                     ! Input data value
CHARACTER(len=20) :: file_name ! Input data file name

! Clear the running sums.
CALL running_average ( 0., ave, std_dev, nvals, .TRUE. )

! Get the name of the file containing the input data.
WRITE (*,*) ' Enter the file name containing the data: '
READ (*,'(A20)') file_name

! Open input data file.  Status is OLD because the input data must
! already exist.
OPEN ( UNIT=21, FILE=file_name, STATUS='OLD', ACTION='READ', &
       IOSTAT=istat )

! Was the OPEN successful?
openok: IF ( istat == 0 ) THEN

   ! The file was opened successfully, so read the data to calculate
   !  running averages for.
   calc: DO
      READ (21,*,IOSTAT=istat) x        ! Get next value
      IF ( istat /= 0 ) EXIT            ! EXIT if not valid.

      ! Get running average & standard deviation
      CALL running_average ( x, ave, std_dev, nvals, .FALSE. )

      ! Now write out the running statistics.
      WRITE (*,1020) 'Value = ', x, '  Ave = ', ave, &
                     '  Std_dev = ', std_dev, &
                     '  Nvals = ', nvals
      1020 FORMAT (1X,3(A,F10.4),A,I6)
   END DO calc

ELSE openok

   ! Else file open failed.  Tell user.
   WRITE (*,1030) istat
   1030 FORMAT (1X,'File open failed--status = ', I6)

END IF openok

END PROGRAM test_running_average


module fheap
  private
  public :: FibNode, FibHeap
  ! Fibonacci heap originally written in C++ by beniz.
  ! https://github.com/beniz/fiboheap
  ! OOP fortran linked lists
  ! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm

  type FibNode
    private
    integer                :: key
    integer                :: degree
    logical                :: mark
    class(*),      pointer :: value  => null()
    type(FibNode), pointer :: parent => null()
    type(FibNode), pointer :: child  => null()
    type(FibNode), pointer :: left   => null()
    type(FibNode), pointer :: right  => null()

  contains
    procedure :: delete_fibnodes => delete_fibnodes ! Delete all nodes.
  end type FibNode

  type, extends(FibNode)    :: FibHeap
    integer                 :: n
    class(FibNode), pointer :: nmin
  end type FibHeap

contains

  recursive subroutine delete_fibnodes(x)
    ! Delete all nodes.
    implicit none
    class(FibNode), intent(inout), target :: x
    class(FibNode), pointer :: cur, tmp

    ! If x is not associated, return. No need to do anything.
    if(.not. associated(x % value)) return

    ! Associate working variable to x.
    cur => x

    ! Loop to Dissociate All Nodes.
    dan: do
      ! Check if Cur % Left is Associated with X.
      clax: if ( .not. associated(cur % left, target = x) ) then
        ! Associate tmp to cur.
        tmp => cur
        ! Associate current to cur % left.
        cur => cur % left
        ! Check whether tmp % child is associated, if it is,
        ! recursively call the function to dissociate it.
        if (associated(tmp % child)) call delete_fibnodes(tmp % child)
        ! Nullify tmp.
        tmp => null()
      else clax
        if (associated(cur % child)) call delete_fibnodes(cur % child)
        cur => null()
        return
      end if clax
    end do dan
  end subroutine delete_fibnodes

  subroutine insert(x, nmin)
    ! Insert new node to fiboheap
    implicit none
    class(FibNode), intent(inout), pointer :: x
    class(FibHeap), intent(inout), pointer :: nmin

    ! Set up the properties of the new node.
    x % degree = 0
    x % parent => null()
    x % child  => null()
    x % mark   = .false.

    ! Check if nMin (node with the minimum key) is Associated.
    ma: if ( .not. associated(nmin) ) then
      ! If nmin is not associated, then there are no nodes in the heap.
      ! Therefore, there is nothing else for x to point to.
      ! We associate x%right and x%left to x (self-reference).
      x % right => x
      x % left  => x % right
      ! We associate nmin with x%left. Through inheritance, it points to x.
      nmin % nmin => x % left
    else ma
      ! Insert x into root list.
      nmin % left % right => x
                x % left  => nmin % left
             nmin % left  => x
              x   % right => nmin % nmin

      if (x % key < nmin % key) nmin % nmin => x
    end if ma

    nmin % n = nmin % n + 1
  end subroutine insert

  subroutine clear_heap(nmin)
    ! Clear all nodes, creating a new heap.
    implicit none
    class(FibHeap), intent(inout), pointer :: nmin

    call delete_fibnodes(nmin % nmin)
    nmin % n = 0
  end subroutine clear_heap

  function get_nmin(nmin)
    ! Get minimum node.
    implicit none
    class(FibHeap), intent(in), pointer :: nmin
    class(FibHeap), pointer             :: get_nmin

    get_nmin => nmin

  end function get_nmin

end module fheap