      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C
C......REVISION HISTORY
C
C   5-95  CRI   MSTP Software Conversion (VICAR PORTING)
C   6-87  KFE   Change output tiepoint format from IBIS graphics-1 file
C		to IBIS interface (tabular) file.
C
C   1-87  SXP   Modified to use LLSQ to solve linear least
C               squares system of equations.
C   9-86  SXP   Modified to access the array processor if it is present unless
C               'NOAP is specified.  Replaced body of RFIT subroutine with
C               call to CROSSCAP for AP execution or CROSSCORR for non-AP
C               execution.  Replaced NOPHASE parameter with more flexible
C               PHASE parameter.  Added NOAP parameter in pdf to make usage
C               of AP selectable.  Modified calling sequence for RFIT
C               subroutine for PHASE and USEAP.  Removed POWER from RFITCOM.
C               The handling of the case where the peak of the cross-correlation
C               matrix is close to the edge of the matrix is different now,
C               presumably better.  In this case the previous code could
C               report a peak where there was none.  (See OFFMAX parameter
C               in help for subroutine CROSSCORR.)
C               The handling of the HPF is a little different now.  Before
C               some terms in the FFTs were not zeroed because they were
C               already 0 theoretically.  Now they are explicitly zeroed
C               in case they were not zero due to roundoff.  The normalization
C               of the correlation for phase with HPF used to divide by
C               32**2.  It now divides by 31**2 since the axes should not be
C               counted with HPF.
C               The test pdf has been expanded.

C               USERS WILL PROBABLY NOTICE MORE TIEPOINTS BEING REJECTED WITH A
C               FAILURE CODE OF 4 (CORRELATION PEAK UNRELIABLE) AND A
C               CORRELATION VALUE OF 0.  THIS IS DUE TO
C               THE DIFFERENCE INVOLVING THE OFFMAX PARAMETER MENTIONED ABOVE.

C   5-86  KFE   General upgrade:
C		  Put in comments, improve code legibility.
C		  Change items output.
C		  Change contour file input from graphics-2 to graphics-1
C		  Add FILTER parameter.
C		  Add STOP parameter.
C		  Update/improve help file.
C
C--------------------------------------------------------------------------
C
C  IBIS PROGRAM PICMATCH: REGISTERS AN IMAGE PAIR ALONG GRAPHICS LINES OR
C	    ON A GRID.
C       THE REGISTRATION SQUARES ARE SAMPLED FROM THE IMAGES TO GIVE
C	    THE BEST AFFINE FIT PRIOR TO FFT
C
C
	IMPLICIT INTEGER*4(A-Q),REAL*4(R-Z)
        INCLUDE 'fortport'

	REAL*4 A(60,3),AA(180),B(60,2),BB(180),X(3,3),AUX(6),CENTR(2)
	REAL*4 PRED(2),CORR(3,3),SHIFT(2),GCNTR(2),AG(3,3),BG(3,2)
        REAL*4 XG(3,2),XID(3,2),RMAG(2),RVEC(10)
	REAL*8 DSUM, SECCOORD(3)
 	REAL*4 FILTER, STOPTHRESH, PHASE

	INTEGER	MAXOUTROWS, MAXOUTCOLS
	PARAMETER (MAXOUTROWS = 5000, MAXOUTCOLS = 14)

	INTEGER	OUTPTR, CLEN, NCOL, COLS(MAXOUTCOLS)
	INTEGER STOPNUM, STOPCOUNT, IBIG
	INTEGER	RUNIT1, RUNIT2, RUNIT3, RUNIT4, STATUS, WUNIT1
	INTEGER SEARCH,SRCHW, II, JJ, RDGR, GETGR, NEXTGR, CLGR

	LOGICAL CONTUR, RETRY, OLDFFT
	LOGICAL XVPTST, NOPRNT, NOCO, NOHPF, SUBPIX
	LOGICAL NOIN/.FALSE./

	CHARACTER*80  PRSTRING

        REAL    OBUF(MAXOUTROWS)
	REAL	OUTBUF(MAXOUTCOLS,MAXOUTROWS)
	REAL	RPARM(3)
	REAL	CONL,CONS, CONL1,CONS1, CONL2,CONS2, CONDL,CONDS
	REAL	CONSEG, CONDELTA, CONLEN, CONMAX

	LOGICAL	EOF, ZERO

	BYTE CHIP1(32,32), ASRCH(128,128)
	BYTE CHIP2(32,32), ASRCH2(128,128) ! for the masks

	REAL	FFTCORR(32,34)
	COMMON /RFITCOM/  CHIP1, ASRCH,  FFTCORR
	COMMON /RFITCOM2/ CHIP2, ASRCH2

        integer inpcount
        common /inputs/ inpcount

	INTEGER GETGRV(4000)
	DIMENSION IPIV(20)
	DATA XID/1.,0.,0.,0.,1.,0./
	DATA AG,BG/1.,1.,2.,1.,2.,2.,5*1.,2.,1.,2.,2./
	DATA RVEC/0.,1.,-1.,1.,-1.,0.,1.,-1.,-1.,1./
	DIMENSION RITIE(20),ROTIE(20),CVEC(3)

C		Get the input parameters
        CALL IFMESSAGE('PICMATCH version 30-SEPT-96')

	CALL XVPARM('ITIE',RITIE,CITIE,PDEF,20)
	CALL XVPARM('OTIE',ROTIE,COTIE,PDEF,20)

        CALL XVP ('MAGNIFY', RMAG, N)
        IF (N.EQ.1) RMAG(2) = RMAG(1)
        CALL XVP ('SEARCH', SEARCH, DUMMY)
        SEARCH = MIN0(128,SEARCH)
        CALL XVP ('MSEARCH', MSRC, DUMMY)
	CALL XVP ('MINCORR', RMCOR, DUMMY)
        CALL XVP ('ZWIND', GETW, DUMMY)
        CALL XVP ('ZREJECT', CVEC, DUMMY)
	GETR = CVEC(1)
	GETZ = CVEC(2)
        NOHPF = XVPTST('NOHPF')
        SUBPIX = .NOT.XVPTST('NOSUBPIX')
        NOCO = XVPTST('NOCORR')
	CALL XVP ('FILTER', FILTER, DUMMY)
	CALL XVP ('PHASE',  PHASE, DUMMY)
        NOPRNT = XVPTST('NOPRINT')
        CALL XVPARM ('CONTOUR', RPARM, DUMMY, CONTDEF, 3)
        CONTUR = CONTDEF .EQ. 0
        CONMAX = RPARM(1)
        IF (NINT(RPARM(2)).EQ.1) THEN
            DO I=1,CITIE
                XT = RITIE(I)
                RITIE(I) = ROTIE(I)
                ROTIE(I) = XT
            ENDDO
	ENDIF
        CALL XVP ('STOP', RPARM, DUMMY)
	STOPNUM = NINT(RPARM(1))
	STOPTHRESH = RPARM(2)
        CALL XVP ('RETRY', RPARM, DUMMY)
	NRETRY = MAX(MIN( NINT(RPARM(1)), 5), 0)
	RETRY = NRETRY .GT. 0
	IF (NRETRY .EQ. 0) NRETRY = 1
	RRETRY = 0.0
        IF (RETRY) THEN
            TRETRY = RPARM(2)
            RRETRY = RPARM(3)
        ENDIF
        IF (.NOT. (CONTUR) ) THEN
            CALL XVP('MINL',XL,DUMMY)
            CALL XVP('MINS',XS,DUMMY)
            CALL XVP('MAXL',YL,DUMMY)
            CALL XVP('MAXS',YS,DUMMY)
            CALL XVP('NAH',NAH,DUMMY)
            CALL XVP('NAV',NAV,DUMMY)
            XLD = (YL-XL)/NAV
            XSD = (YS-XS)/NAH
            LCOUNT = (NAH+1)*(NAV+1)
	ENDIF

c
c       get the count of the input files
c
c       2 = just two images to be correlated
c       3 = two images and a contour file
c       4 = two images + two masks
c       5 = two images, two masks, and one contour file
c
c
c
        CALL XVPCNT ('INP', INPCOUNT)

C		Open first input file (first image).
        CALL XVUNIT (RUNIT1, 'INP', 1, STATUS,' ')
        CALL XVOPEN (RUNIT1, STATUS, 'OPEN_ACT','SA',
     &          'IO_ACT','SA',' ')
        CALL XVGET (RUNIT1, STATUS, 'NL',NL1, 'NS',NS1,' ')

        CALL XVUNIT (RUNIT2, 'INP', 2, STATUS,' ')
        CALL XVOPEN (RUNIT2, STATUS, 'OPEN_ACT','SA',
     &               'IO_ACT','SA',' ')
        CALL XVGET (RUNIT2, STATUS, 'NL',NL2, 'NS',NS2,' ')

c
C		Open third input file (optional graphics-1 contour file).
c
	IF (CONTUR) THEN
	    STATUS = RDGR (3, 2, 2)
        ENDIF
c
c       check for only the coutour ibis1 graphics file
c
        if ( inpcount .eq. 3 ) go to 10
c
c               Optionally open the mask files
c
        if ( inpcount .gt. 2 ) then    ! set up input unit #'s
            mask1 = 3
            mask2 = 4
            if ( contur ) then
                mask1 = 4
                mask2 = 5
            end if

            CALL XVUNIT (RUNIT4, 'INP', mask1, STATUS,' ')
            CALL XVOPEN (RUNIT4, STATUS, 'OPEN_ACT','SA',
     &          'IO_ACT','SA',' ')

            CALL XVUNIT (RUNIT5, 'INP', mask2, STATUS,' ')
            CALL XVOPEN (RUNIT5, STATUS, 'OPEN_ACT','SA',
     &               'IO_ACT','SA',' ')
        end if

C		Process itie-otie to set up the affine transform.

 10     continue
        DO I = 1, 60
            A(I,3) = 1.0
        ENDDO

        COUNT = CITIE/2

        IF (COUNT.NE.COTIE/2) THEN
	    CALL XVMESSAGE
     &        ('NUMBER OF OTIE MUST EQUAL NUMBER OF ITIE',' ')
	    CALL ABEND
	ENDIF

        DO  I=1,COUNT
           A(I,1) = ROTIE(I*2-1)
           A(I,2) = ROTIE(I*2)
           B(I,1) = RITIE(I*2-1)
           B(I,2) = RITIE(I*2)
        ENDDO

        NEQ = MIN0(COUNT,20)
        NEQP = NEQ

        DO I=1,COUNT
           AG(I,1) = ROTIE(I*2-1)
           AG(I,2) = ROTIE(I*2)
           BG(I,1) = RITIE(I*2-1)
           BG(I,2) = RITIE(I*2)
        ENDDO

	EPS = 1.E-7

C		Find the affine transformation from the ITIE-OTIE that
C		    defines how the chips are extracted from the first image
	CALL LLSQ (AG,BG, COUNT,3,2, XG, IPIV,EPS,IER,AUX)
	IF (IER.NE.0) THEN
	    CALL XVMESSAGE
     &	 ('LEAST SQUARES ON ITIE-OTIE FAILED, TRANSFORM NOT SET',' ')
	    CALL ABEND
	ENDIF

C		Find the initial transformation that gives the location
C		    of the estimated points in the first image
	DO I=1,NEQ
	    DO J=1,3
		AA(I+(J-1)*NEQ) = A(I,J)
		IF (J.NE.3) BB(I+(J-1)*NEQ) = B(I,J)
	    ENDDO
	ENDDO

	CALL LLSQ (AA,BB, NEQ,3,2, X, IPIV,EPS,IER,AUX)
	IF (IER.NE.0) THEN
	    CALL XVMESSAGE('ERROR IN GEOMETRICAL MODEL FIT',' ')
	    CALL ABEND
	ENDIF

	SECCOORD(3) = 1.D0

	IF (.NOT. NOPRNT) THEN
	    PRSTRING = 'SEQ     SECOND LOCATION   ESTIMATED LOCATION'
     *		//'   FIRST LOCATION  CORR WIN  RES FN'
	    CALL XVMESSAGE(PRSTRING,' ')
	ENDIF

	SRCHW = SEARCH-32
	MSRCHW = MSRC-32

	IF (CONTUR) THEN
	    STATUS = NEXTGR (2, EOF, CONL2, CONS2)
	    IF (EOF) GOTO 200
	    CONL1 = CONL2
	    CONS1 = CONS2
	    CONSEG = 0.0
	    CONDELTA = 1.0
	    CONDL = 0.0
	    CONDS = 0.0
	ENDIF

	OUTPTR = 1
	STOPCOUNT = 0
	IBIG = 0

C**********************************************
C	MAIN LOOP THROUGH ALL MATCHING POINTS

 100	CONTINUE
	IBIG = IBIG + 1

	DO 1000 JBIG = 1, NRETRY
	VMAX = 0.0

        IF (CONTUR) THEN
C   Find chip location for contour option
	   IF (CONSEG .GE. 1.0) THEN
	      CONL1 = CONL2
	      CONS1 = CONS2
 	      STATUS = GETGR (2, ZERO, EOF, CONL2, CONS2)
	      IF (EOF) GOTO 200
	      IF (ZERO) THEN
		 STATUS = NEXTGR (2, EOF, CONL2, CONS2)
		 IF (EOF) GOTO 200
		 CONL1 = CONL2
		 CONS1 = CONS2
	      ENDIF
	      CONDL = CONL2 - CONL1
	      CONDS = CONS2 - CONS1
	      CONLEN = SQRT( CONDL**2 + CONDS**2)
	      CONDELTA = CONMAX/(CONLEN + 1.0E-4)
	      CONSEG = 0.0
	   ENDIF
	   CONSEG = MIN( CONSEG + CONDELTA, 1.0)
	   CONL = CONL1 + CONSEG*CONDL
	   CONS = CONS1 + CONSEG*CONDS
	   XLT = CONL + RRETRY*RVEC(JBIG)
	   XST = CONS + RRETRY*RVEC(JBIG+5)

	ELSE
C		Find chip location for grid option
	   IF (IBIG .GT. LCOUNT) GOTO 200
	   IHOR = MOD(IBIG-1,NAH+1)
	   IVER = (IBIG-1)/(NAH+1)
	   XLT = XL + FLOAT(IVER)*XLD + RRETRY*RVEC(JBIG)
	   XST = XS + FLOAT(IHOR)*XSD + RRETRY*RVEC(JBIG+5)
	ENDIF
	CENTR(1) = 16.5
	CENTR(2) = 16.5
	GCNTR(1) = INT(XLT)+0.5
	GCNTR(2) = INT(XST)+0.5
	SECCOORD(1) = DBLE(GCNTR(1))
	SECCOORD(2) = DBLE(GCNTR(2))

C		Use the geometric model to estimate the matching point
C		    location in the first image
	DO I = 1,2
	    DSUM = 0.D0
	    DO J=1,3
		DSUM = DSUM + SECCOORD(J)*DBLE(X(J,I))
	    ENDDO
	    PRED(I) = INT(SNGL(DSUM))+.5
	ENDDO
	WL = PRED(1)
	WS = PRED(2)
	IF (PRED(1) .LT. 1.0 .OR. PRED(1) .GT. FLOAT(NL1) .OR.
     +      PRED(2) .LT. 1.0 .OR. PRED(2) .GT. FLOAT(NS1) ) GOTO 1000

C		Extract grid from the second image.
	CALL GETGRD(RUNIT2,CHIP1,32,GETGRV,8000,32,NL2,NS2,
     *              GCNTR,XID,SHIFT,RMAG,CHOP,NOIN,NOINV,*1000)
	IFAIL = 1
	IF (CHOP .GE. 100) GO TO 1001

C		Extract grid from mask of the second image
        if ( inpcount .gt. 3 ) then
   	    CALL GETGRD(RUNIT3,CHIP2,32,GETGRV,8000,32,NL2,NS2,
     *              GCNTR,XID,SHIFT,RMAG,CHOP,NOIN,NOINV,*1000)
        end if

C		Extract grids in the search window of the first image
	MM = (MIN0(128,SRCHW+40)/2)*2

        do ii = 1, 128       ! clear the search arrays
          do jj = 1, 128
            asrch(ii,jj) = 0
            if ( inpcount .gt. 3 ) asrch2(ii,jj) = 0
          enddo
        enddo

	CALL GETGRD(RUNIT1,ASRCH,128,GETGRV,8000,MM,NL1,NS1,
     *            PRED,XG,SHIFT,RMAG,CHOP,NOIN,NOINV,*1000)

C		Extract grid from mask of the second image
        if ( inpcount .gt. 3 ) then
    	    CALL GETGRD(RUNIT3,ASRCH2,128,GETGRV,8000,MM,NL1,NS1,
     *            PRED,XG,SHIFT,RMAG,CHOP,NOIN,NOINV,*1000)
        end if

c
c       check for no correlation
c
	IF (NOCO) GO TO 99

C		Iterate over window for best match
	WMAX = -1.E20
	PSRCH = 49-SRCHW/2
	NAHV = (SRCHW+23)/12
	NWID = 1
	IF (NAHV.GE.2) NWID = SRCHW/(NAHV-1)
	OLDFFT = .FALSE.
	DO IH = 1, NAHV
	    ILIN = PSRCH+(IH-1)*NWID
	    DO JV = 1, NAHV
		JSMP = PSRCH+(JV-1)*NWID
		CALL RFIT(ILIN,JSMP, VMAX, VLOFF, VSOFF, CORR,
     *				NOHPF, OLDFFT, PHASE, FILTER )

		OLDFFT = .TRUE.
		IF (VMAX.GT.WMAX) THEN
		    WMAX = VMAX
		    WLMAX = VLOFF+FLOAT(ILIN)
		    WSMAX = VSOFF+FLOAT(JSMP)
		ENDIF
	    ENDDO
	ENDDO

C		Refine the match location at the correlation peak
	IFAIL = 4
	ILIN = INT(WLMAX)
	JSMP = INT(WSMAX)
	IF (ILIN.LE.0.OR.ILIN.GE.98) GO TO 1001
	IF (JSMP.LE.0.OR.JSMP.GE.98) GO TO 1001
        IF ( WMAX .LE. 0 )           GOTO  1001   ! CASE OF NO GOOD PEAKS.
	CALL RFIT(ILIN,JSMP, VMAX, VLOFF, VSOFF, CORR,
     *		NOHPF, OLDFFT, PHASE, FILTER )

        IF ( VMAX .LE. 0 )           GOTO  1001   ! CASE OF NO GOOD PEAK.

C		If subpixel accuracy desired fit the parabola to peak
	IFAIL = 5

	IF (SUBPIX) CALL REFINE(CORR,VLOFF,VSOFF,*1001)
	WLD = FLOAT(ILIN)+VLOFF+CENTR(1)-65.5

	WSD = FLOAT(JSMP)+VSOFF+CENTR(2)-65.5
	WL = PRED(1) + (XG(1,1)*WLD+XG(2,1)*WSD)*RMAG(1)
	WS = PRED(2) + (XG(1,2)*WLD+XG(2,2)*WSD)*RMAG(2)

	IFAIL = 2
	IF (RETRY .AND. (VMAX.LT.TRETRY)) GO TO 1001

 99	CONTINUE

C		Get the average brightnesses at the matching locations
	CALL GETZVL(CHIP1,32,CENTR(1),CENTR(2),GETW,GETR,GETZ,Z2)
	CALL GETZVL(ASRCH,128,64.5+WLD,64.5+WSD,GETW,GETR,GETZ,Z1)

C		Output stuff to first output file
	OUTBUF(1,OUTPTR) = WL
	OUTBUF(2,OUTPTR) = WS
        OUTBUF(3,OUTPTR) = SNGL(SECCOORD(1))
	OUTBUF(4,OUTPTR) = SNGL(SECCOORD(2))
	OUTBUF(5,OUTPTR) = PRED(1)
	OUTBUF(6,OUTPTR) = PRED(2)
	OUTBUF(7,OUTPTR) = Z1
	OUTBUF(8,OUTPTR) = Z2
	OUTBUF(9,OUTPTR) = VMAX
	OUTBUF(10,OUTPTR) = FLOAT(IBIG)
	OUTPTR = OUTPTR + 1
	IF (OUTPTR .GT. MAXOUTROWS)  GOTO 200

C		Calculate the distance between predicted and correlation point
      RES = SQRT( (PRED(1)-WL)**2 + (PRED(2)-WS)**2 )
      IF (.NOT. NOPRNT) THEN
          WRITE (PRSTRING,
     *		'(I4,3(2X,F8.2,1X,F8.2),1X,F5.3,1X,I3,F6.1)' )
     *			IBIG,  SECCOORD(1), SECCOORD(2),
     *			PRED(1), PRED(2), WL, WS, VMAX, SRCHW+32, RES
          CALL XVMESSAGE (PRSTRING,' ')
      ENDIF

C		If correlation value is high enough then add point
C		    to geometric model
	IF (VMAX .GE. RMCOR) THEN
	    NEQ = MIN0(NEQ+1,60)
	    NEQP = MOD(NEQP,60)+1
	    A(NEQP,1) = SNGL(SECCOORD(1))
	    A(NEQP,2) = SNGL(SECCOORD(2))
	    B(NEQP,1) = WL
	    B(NEQP,2) = WS
	    DO I=1,NEQ
		DO J=1,3
		    AA(I+(J-1)*NEQ) = A(I,J)
		    IF (J.NE.3) BB(I+(J-1)*NEQ) = B(I,J)
		ENDDO
	    ENDDO

	    CALL LLSQ (AA,BB, NEQ,3,2, X, IPIV,EPS,IER,AUX)
	    IF (IER.NE.0) THEN
		CALL XVMESSAGE('ERROR IN GEOMETRICAL MODEL FIT',' ')
		CALL ABEND
	    ENDIF
C			Adjust the search window based on the last residual
	    SRCHW = MIN0(MAX0(MSRCHW,(4*SRCHW+2*INT(RES))/5),SRCHW)
	ENDIF

	IF (RETRY) GOTO 100   ! RETRY corr was above threshold so stop retries

 1000	CONTINUE
 1010   CONTINUE
C		Stop the program if we have enough good matching points
C		    above the threshold
	IF (VMAX .GE. STOPTHRESH) THEN
	    STOPCOUNT = STOPCOUNT + 1
	    IF (STOPCOUNT .EQ. STOPNUM) GOTO 200
	ENDIF

	GOTO 100
C		End of main loop

  200   CONTINUE

C		Open first output file (IBIS interface (tabular) file
C		    containing correlation results).
C		Output all the tiepoints.
	CLEN = OUTPTR - 1
	NCOL = 10
	DO I = 1, NCOL
	    COLS(I) = I
	ENDDO
        CALL XVUNIT(WUNIT1,'OUT',1,STATUS,' ')
        IF (STATUS.NE.1) THEN
           CALL XVMESSAGE
     &  ('OUTPUT FILE INITIALIZATION ERROR-PROGRAM TERMINATED',' ')
           CALL ABEND
        ENDIF
        CALL IBIS_FILE_OPEN(WUNIT1,OUTIBIS,'WRITE',NCOL,CLEN,' ',
     &     'COLUMN',STATUS)
        IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(WUNIT1,STATUS,1)

	DO I = 1, NCOL
          DO JJ = 1, CLEN
            OBUF(JJ) = OUTBUF(I,JJ)
          ENDDO
          CALL IBIS_COLUMN_WRITE(OUTIBIS,OBUF,I,1,CLEN,STATUS)
          IF (STATUS.NE.1) CALL IBIS_SIGNAL(OUTIBIS,STATUS,1)
C         CALL PUTREC (WUNIT1, NCOL, COLS, OUTBUF(1,I), I, CLEN, IOBUF)
	ENDDO

   	CALL XVCLOSE (WUNIT1,STATUS,' ')

C		Close up the files
	CALL XVCLOSE (RUNIT1,STATUS,' ')
	CALL XVCLOSE (RUNIT2,STATUS,' ')
	IF (CONTUR) STATUS = CLGR (2)

C		Print out the final geometrical model
	IF (.NOT. NOPRNT) THEN
	    WRITE (PRSTRING, '(A,3(1X,F12.5))')
     *			 ' FINAL FIT: LINE   = ',
     *			X(1,1), X(2,1), X(3,1)
	    CALL XVMESSAGE(PRSTRING,' ')
	    WRITE (PRSTRING, '(A,3(1X,F12.5))')
     *			 ' FINAL FIT: SAMPLE = ',
     *			X(1,2), X(2,2), X(3,2)
	    CALL XVMESSAGE(PRSTRING,' ')
	ENDIF

	GO TO 9999

 1001	CONTINUE
C		Printout failure report numbers
	IF (.NOT. NOPRNT) THEN
	    WRITE (PRSTRING,
     *		'(I4,3(2X,F8.2,1X,F8.2),1X,F5.3,1X,I3,7X,I1)' )
     *			IBIG,  SECCOORD(1), SECCOORD(2),
     *			PRED(1), PRED(2), WL, WS, VMAX, SRCHW+32, IFAIL
	    CALL XVMESSAGE(PRSTRING,' ')

	ENDIF
	GOTO 1010

 9999	CONTINUE

	RETURN
	END

      SUBROUTINE REFINE(CORR,VLOFF,VSOFF,*)
      INTEGER*4 IPIV(6)
      REAL*4 CORR(3,3),A(9,6),B(9),S(6),AUX(12)

C
      DO 1 I=1,3
      Y = FLOAT(I)
      DO 1 J=1,3
      X = FLOAT(J)
      IQ = (I-1)*3+J
      A(IQ,1) = X*X
      A(IQ,2) = X*Y
      A(IQ,3) = Y*Y
      A(IQ,4) = X
      A(IQ,5) = Y
      A(IQ,6) = 1.
 1    B(IQ) = CORR(J,I)
      EPS = 1.E-7
      CALL LLSQ(A,B,9,6,1,S,IPIV,EPS,IER,AUX)
      IF (IER.NE.0) RETURN 1
      IF (S(1).EQ.0.) RETURN 1
      B2A = S(2)/(S(1)*2.)
      Y0 = (B2A*S(4)-S(5))/(2.*S(3)-B2A*S(2))-2.
      X0 = -B2A*(Y0+2.)-S(4)/(S(1)*2.)-2.
      IF (X0*X0+Y0*Y0.GE.4.) RETURN

      VLOFF = VLOFF+Y0
      VSOFF = VSOFF+X0
      RETURN
      END

      SUBROUTINE GETZVL(A,N,FL,FS,NW,NR,NZ,Z)
      INCLUDE 'fortport'
      BYTE A(N,N),KLOG(4)
C
      KINT = 0
      ILL = INT(FL)-NW/2-1
      JSL = INT(FS)-NW/2-1
      FLU = FL-INT(FL)
      FSU = FS-INT(FS)
      FLL = 1.-FLU
      FSL = 1.-FSU
      ILU = ILL+NW-1
      JSU = JSL+NW-1
      Z = -999.0
      IF (ILL.LT.1.OR.ILU.GT.N) RETURN
      IF (JSL.LT.1.OR.JSU.GT.N) RETURN
C
      IRE = 0
      SUM = 0.
      DO 10 I=ILL,ILU
      DO 10 J=JSL,JSU
        KLOG(1) = A(J,I)
        KINT = BYTE2INT(KLOG(1))
        IF (KINT.LE.NZ) IRE = IRE+1
        FDATA = FLOAT(KINT)
        IF (I.EQ.ILL) FDATA = FDATA*FLL
        IF (I.EQ.ILU) FDATA = FDATA*FLU
        IF (J.EQ.JSL) FDATA = FDATA*FSL
        IF (J.EQ.JSU) FDATA = FDATA*FSU
        SUM = SUM+FDATA
 10   CONTINUE
      IF (IRE.LE.NR) Z = SUM/FLOAT((NW-1)*(NW-1))
C
      RETURN
      END

      SUBROUTINE GETGRD(RUNIT,GRID,NDIM,BUFIN,LBUFIN,N,LINE,
     *       SAMP,CENTR,TRANS,SHIFT,MAGNIF,CHOP,NOIN,NOINV,*)
C
C---- VICAR SUBROUTINE "GETGRD".
C     PURPOSE:    TO OBTAIN THE DN-VALUES IN THE POINTS
C   OF THE LINEARLY TRANSFORMED GRID.
C   DN-VALUES ARE OBTAINED BY THE BILINEAR
C   INTERPOLATION BETWEEN FOUR PIXELS
C   ADJACENT TO THE GRID POINT.
C     PARAMETERS: RUNIT - UNIT NUMBER OF IMAGE
C   GRID  - OUTPUT L*1 ARRAY OF INTERPOLATED DN-VALUES.
C   NDIM  - DIMENSION OF THE GRID(NDIM MAX=128), EVEN
C   BUFIN - WORK AREA, TWO-DIMENSIONAL L*1 ARRAY
C    BUFIN(LBUFIN,2), LBUFIN>NDIM*MAGN(2)+50
C   LBUFIN- DEFINES THE SIZE OF BUFIN.
C   N     - DEFINES THE PORTION OF THE GRID
C    TO BE PROCESSED (MUST BE EVEN).
C   LINE  - NUMBER OF LINES IN THE IMAGE.
C   SAMP  - NUMBER OF SAMPLES IN THE IMAGE.
C   CENTR - ARRAY, CENTR(1)=Y OF THE GRID CENTER,
C    CENTR(2)=X OF THE GRID CENTER.
C   TRANS - ARRAY OF THE GRID TRANSFORMATION COEFFICIENTS:
C    YNEW=TRANS(1)*YOLD+TRANS(2)*XOLD+TRANS(3)
C    XNEW=TRANS(4)*YOLD+TRANS(5)*XOLD+TRANS(6)
C   SHIFT - VECTOR TO ADD TO THE TRANSFORMED GRID
C    TO BRING ITS CENTER TO "CENTR".
C   MAGNIF- ARRAY CONTAINING MAGNIFICATION OF
C    X- AND Y- DISTANCES IN THE GRID.
C   CHOP  - NUMBER OF GRID POINTS OUTSIDE THE IMAGE.
C    CORRESPONDING DN-VALUES IN THE "GRID"
C    ARE SET TO ZERO.
C     PROGRAMMER:  BORIS GOKHMAN, OCTOBER 1980.
C
      INCLUDE 'fortport'
      LOGICAL NOIN
      BYTE GRID(1)
      BYTE BUFIN(LBUFIN,2)
      BYTE LOGDN(4),LPIX1(4),LPIX2(4),LPIX3(4),LPIX4(4)
      INTEGER*4 DN1,DN2,DN3,DN4
      INTEGER*4 IDN

      DIMENSION TRANS(6),CENTR(2),SHIFT(2)
      REAL*4 MAGNIF(2)
      REAL*4 Y(4),X(4)
      INTEGER*4 CHOP,LINE,SAMP
      INTEGER*4 ISTART(128)
      INTEGER*4 ISGNES(4), JSGNES(4)
      DIMENSION YINC1(128),XINC2(128),YINC4(128),XINC5(128)
      LOGICAL ENDJ(128)

      DATA ISGNES / 1, -1, -1, 1 /
      DATA JSGNES / 1, 1, -1, -1 /
C
C---- PRELIMINARY CALCULATIONS
C
      IDN = 0
      DN1 = 0
      DN2 = 0
      DN3 = 0
      DN4 = 0
      NOFFB = (NDIM-N)*(NDIM+1)/2
      IHI = 1
      ILOW = 2
      RLINE = LINE
      RSAMP = SAMP
      CHOP = 0
      IF(CENTR(1).LT.1..OR.CENTR(1).GT.RLINE) RETURN 1
      IF(CENTR(2).LT.1..OR.CENTR(2).GT.RSAMP) RETURN 1
      GAPX = MAGNIF(2)
      GAPY = MAGNIF(1)
      SHIFT(1) = CENTR(1)-(N+1)/2.*(TRANS(1)+TRANS(2))-TRANS(3)
      SHIFT(2) = CENTR(2)-(N+1)/2.*(TRANS(4)+TRANS(5))-TRANS(6)
      XMIN = (N+1)/2.-GAPX*(N-1)/2.
      YMIN = (N+1)/2.-GAPY*(N-1)/2.
      XMAX = (N+1)/2.+GAPX*(N-1)/2.
      YMAX = (N+1)/2.+GAPY*(N-1)/2.

C---- FIND THE UPPERMOST CORNER OF THE TRANSFORMED QUAD
C     AND THE SIGN OF THE ARRAY INDEXES CHANGE.
C
      Y(1) = TRANS(1)*YMIN+TRANS(2)*XMIN+TRANS(3)+SHIFT(1)
      Y(2) = TRANS(1)*YMAX+TRANS(2)*XMIN+TRANS(3)+SHIFT(1)
      Y(3) = TRANS(1)*YMAX+TRANS(2)*XMAX+TRANS(3)+SHIFT(1)
      Y(4) = TRANS(1)*YMIN+TRANS(2)*XMAX+TRANS(3)+SHIFT(1)

      IMIN = 1
      DO 20 I=2,4
          IF(nint(Y(I)) .LT. nint(Y(IMIN))) IMIN = I
   20 CONTINUE
      ISIG = ISGNES(IMIN)
      JSIG = JSGNES(IMIN)
C
C---- FIND THE SAMPLE COORDINATES OF LEFTMOST AND
C     RIGHTMOST CORNERS OF THE GRID.
C
      X(1) = TRANS(4)*YMIN+TRANS(5)*XMIN+TRANS(6)+SHIFT(2)
      X(2) = TRANS(4)*YMAX+TRANS(5)*XMIN+TRANS(6)+SHIFT(2)
      X(3) = TRANS(4)*YMAX+TRANS(5)*XMAX+TRANS(6)+SHIFT(2)
      X(4) = TRANS(4)*YMIN+TRANS(5)*XMAX+TRANS(6)+SHIFT(2)
      IABBR = X(1)
      IRIGHT = X(1)
      DO 21 I=2,4
          IF(X(I).LT.IABBR) IABBR = X(I)
          IF(X(I).GT.IRIGHT) IRIGHT = X(I)
   21 CONTINUE
      IABBR = MAX0(IABBR-10,0)
      ICOUNT = IRIGHT-IABBR+10
C
C---- SET UP PARAMETERS FOR THE LOOP.
C
      T1GAPY = TRANS(1)*GAPY
      T2GAPX = TRANS(2)*GAPX
      T4GAPY = TRANS(4)*GAPY
      T5GAPX = TRANS(5)*GAPX
      BASEY = TRANS(1)*(YMIN-GAPY)+TRANS(2)*(XMIN-GAPX)+
     * TRANS(3)+SHIFT(1)
      BASEX = TRANS(4)*(YMIN-GAPY)+TRANS(5)*(XMIN-GAPX)+
     * TRANS(6)+SHIFT(2)
      DO 30 I=1,N
          YINC1(I) = T1GAPY*I
          XINC2(I) = T2GAPX*I
          YINC4(I) = T4GAPY*I
          XINC5(I) = T5GAPX*I
   30 ISTART(I) = 1
      I0 = (N+1)*(1-ISIG)/2
      J0 = (N+1)*(1-JSIG)/2

      JFIN = J0+ISIGN(N,JSIG)
   60 IREC = Y(IMIN)
      IF(IREC.GT.0.AND.IREC.LE.LINE)
     *  CALL XVREAD(RUNIT,BUFIN(1,1),STATUS,'LINE',IREC,'SAMP',IABBR+1,
     *            'NSAMPS',ICOUNT,' ')
      IREC = IREC+1
      IF(IREC.GT.0.AND.IREC.LE.LINE)
     *   CALL XVREAD(RUNIT,BUFIN(1,2),STATUS,'LINE',IREC,'SAMP',IABBR+1,
     *            'NSAMPS',ICOUNT,' ')
C
C---- BEGIN THE LOOP
C
  100 CONTINUE
      DO 300 J1=1,N
      J = J0+ISIGN(J1,JSIG)

      IF(.NOT.ENDJ(J).AND.ISTART(J).EQ.N) GO TO 300
      IST = ISTART(J)
      ENDJ(J) = .FALSE.
      DO 200 I1=IST,N
          I = I0+ISIGN(I1,ISIG)
          Y0 = BASEY+YINC1(I)+XINC2(J)
          X0 = BASEX+YINC4(I)+XINC5(J)
          IF(Y0.GE.IREC.AND.I1.EQ.1) GO TO 400
C CHECK IF THE END OF COLUMN #J IN THE STRIP IS REACHED
          ISTART(J) = I1
          IF(Y0.LT.IREC) GO TO 240
          ENDJ(J) = .TRUE.
          GO TO 300
  240    CONTINUE
          IF(X0.GE.1.0.AND.X0.LE.RSAMP.AND.Y0.GE.1.0.AND.Y0.LE.RLINE)
     *		 GO TO 210
          IDN = 0
          CHOP = CHOP+1
          GO TO 220
  210    CONTINUE
          IX = X0
          JX = IX-IABBR
          JXPLUS = JX+1
          IY = Y0
          LPIX1(1) = BUFIN(JX,IHI)
          DN1 = BYTE2INT(LPIX1(1))
          LPIX2(1) = BUFIN(JXPLUS,IHI)
          DN2 = BYTE2INT(LPIX2(1))
          LPIX3(1) = BUFIN(JX,ILOW)
          DN3 = BYTE2INT(LPIX3(1))
          LPIX4(1) = BUFIN(JXPLUS,ILOW)
          DN4 = BYTE2INT(LPIX4(1))
      IF (NOIN) GO TO 9000
          FACTX = (X0-IX)
          DN12 = DN1+(DN2-DN1)*FACTX
          DN34 = DN3+(DN4-DN3)*FACTX
c          IDN = DN12+(DN34-DN12)*(Y0-IY)+.5
          IDN = nint(DN12+(DN34-DN12)*(Y0-IY))
  220 CONTINUE
          LOGDN(1) = INT2BYTE(IDN)
          GRID(NDIM*(I-1)+J+NOFFB) = LOGDN(1)

  200 CONTINUE
  300 CONTINUE
C
C---- READ THE NEW LINE AND REPEAT THE LOOP
C     OR EXIT
C
  400 CONTINUE
      IF(.NOT.ENDJ(JFIN).AND.ISTART(JFIN).EQ.N) RETURN
C
C---- READ THE NEW LINE.
C
      I = IHI
      IHI = ILOW
      ILOW = I
      IREC = IREC+1
      IF(IREC.GT.0.AND.IREC.LE.LINE)
     *CALL XVREAD(RUNIT,BUFIN(1,ILOW),STATUS,'LINE',IREC,'SAMP',IABBR+1,
     *            'NSAMPS',ICOUNT,' ')
      GO TO 100
C
c 9000 JQ=X0-IABBR+.5
 9000 JQ=nint(X0-IABBR)
c      IQ=Y0+.5
      IQ=nint(Y0)
      JREC = IREC
      IF(JQ.EQ.JX .AND. IQ.EQ.(JREC-1))     LOGDN(1)=LPIX1(1)
      IF(JQ.EQ.JXPLUS .AND. IQ.EQ.(JREC-1)) LOGDN(1)=LPIX2(1)
      IF(JQ.EQ.JX .AND. IQ.EQ.JREC)         LOGDN(1)=LPIX3(1)
      IF(JQ.EQ.JXPLUS .AND. IQ.EQ.JREC)     LOGDN(1)=LPIX4(1)
      IDN = BYTE2INT(LOGDN(1))
      NOINV = IDN
      END

      SUBROUTINE RFIT(IL,JS, VMAX, VLOFF, VSOFF, CORR,
     *			NOHPF, OLDFFT, PHASE, FILTER )
C
C	RFIT performs both regular and phase correlation between
C	    CHIP1 and a 32x32 part of ASRCH which are in RFITCOM common.
C
C	Parameters:
C	  IL	 input	integer		line position in ASRCH
C	  JS	 input	integer		sample position in ASRCH
C	  VMAX	 output real		maximum correlation value
C	  VLOFF	 output real		line offset of correlation peak
C	  VSOFF	 output real		sample offset of correlation peak
C	  CORR   output real array	3x3 array around corr. peak
C	  NOHPF	 input  logical		.true. to zero first column and row
C	  OLDFFT input	logical		.true. to use old FFT in matrix A
C	  PHASE  input  real		amount of phase correlation
C	  FILTER input  real		power of power law filter in FFT
C         USEAP  input  logical         .true. if array processor is to be used.

      IMPLICIT NONE
      INTEGER	IL, JS
      REAL	VMAX, VLOFF, VSOFF, CORR(3,3), FILTER, PHASE
      LOGICAL	NOHPF, OLDFFT

      INTEGER	I,J, IXMAX, JXMAX, DCODE, M, N, KL, KS, ISTATUS
      REAL   	OFFMAX

      BYTE CHIP1(32,32), ASRCH(128,128)
      BYTE CHIP2(32,32), ASRCH2(128,128)
      REAL*4    C(32,34)

      COMMON /RFITCOM/  CHIP1, ASRCH,  C
      COMMON /RFITCOM2/ CHIP2, ASRCH2

      integer inpcount
      common /inputs/   inpcount

C=======================================================

      DCODE = 1             ! BYTE DATA
      M     = 32
      N     = 32
      OFFMAX =  18./32.     ! OLD RFIT USED TO CHECK ABOUT HALF THE CORR. MATRIX

      if ( inpcount .lt. 4 ) then
          CALL CROSSCORR( CHIP1,32, ASRCH(JS,IL),128, M,N, DCODE,
     +                .NOT. OLDFFT, .NOT. NOHPF, PHASE, FILTER, OFFMAX,
     +                 C, KL,KS, VMAX, ISTATUS)
      else
          CALL CROSSCORR4( CHIP1,32,ASRCH(JS,IL),128,
     +                 chip2,asrch2(js,il),
     +                 M,N, DCODE,
     +                .NOT. OLDFFT, .NOT. NOHPF, PHASE, FILTER, OFFMAX,
     +                 C, KL,KS, VMAX, ISTATUS)
      end if

      IF (ISTATUS .LT. 0)  CALL MABEND( ' ERROR IN CROSSCORR' )

      IF (ISTATUS .EQ. 2 )   THEN     ! IGNORE PEAK IF TOO CLOSE TO MATRIX EDGE.
         VMAX =  0.
         VLOFF = 0.
         VSOFF = 0.
         DO I = 1, 3
           DO J = 1, 3
             CORR(J,I) = VMAX
           ENDDO
         ENDDO

      ELSE
C		Calculate the offsets and extract the correlation peak area

        VLOFF = FLOAT(KL)
        VSOFF = FLOAT(KS)
        IXMAX = KL + 17
        JXMAX = KS + 17

         DO I = 1, 3
           DO J = 1, 3
             CORR(J,I) = C(JXMAX+J-2,IXMAX+I-2)
           ENDDO
         ENDDO

      END IF

      RETURN
      END
C********************************************************************

      SUBROUTINE crosscorr4( A,IA, B,IB, M,N, DCODE, FIRST, HPF, PHASE,
     .                      PFILTER, OFFMAX,
     .                      C, IL,IS, QUAL, ISTATUS )
C#######################################################################
C  NAME OF ROUTINE
C      crosscorr4 (CROSS-CORRelation)
C  PREPARED FOR USE ON MIPL SYSTEM BY
C      STEVE POHORSKY   STERLING SOFTWARE        6-86
C  FOR
C      MIPL SOFTWARE DEVELOPMENT
C  ENVIRONMENT
C      VAX 11       VMS  with TAE/VICAR2 EXECUTIVE       FORTRAN-77
C
C  REVISION HISTORY
C     5-90  SP   INCREASED MAXIMUM FOR M AND N FROM 128 TO 512.
C     4-94  AS (CRI) MSTP S/W CONVERSION (VICAR PORTING)
C     3-95  AS (CRI) Removed LIB_LOCAL as per FR85771
c     9/96  BAM  ADDED 2 MORE ARRAYS FOR 4 BUFFER CROSSCORRELATION
c
c
C  PROGRAM LIMITATIONS
C      SEE HLP FILE.
C  SUBROUTINES CALLED
C      FLOATA, FTCORR, MVE, XVMESSAGE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      IMPLICIT NONE

C...ARGUMENT DECLARATIONS

      BYTE        A(*),B(*)
      INTEGER*4   IA, IB, M, N, DCODE, IL,IS, ISTATUS
      LOGICAL*4   FIRST, HPF
      REAL*4      PHASE, PFILTER, OFFMAX, C(N,M+2), QUAL

C...LOCAL DECLARATIONS

      INTEGER*4   I,  IPTRA,   IPTRB,   JPTR,   LSIZEA,  LSIZEB,
     .            MCODE,       MAXM_PAR,        MM2_PAR, PIXSIZE(8)

      PARAMETER   (MAXM_PAR = 512)       ! MAX FOR M & N.  COULD BE INCREASED.
      PARAMETER   (MM2_PAR  = MAXM_PAR*(MAXM_PAR+2))

      REAL*4      FA(MM2_PAR), FB(MM2_PAR)
      SAVE        FA                     ! FFT OF A SLEPT HERE.

      DATA        PIXSIZE  /  1, 2, 0, 4, 0, 0, 4, 8  /  ! BYTES PER PIXEL

C
C======================START OF EXECUTABLE CODE======================

      ISTATUS = 0

C...CONVERT IMAGE DATA TO REAL*4 AND MOVE INTO FA & FB.

      LSIZEA = IA * PIXSIZE(DCODE)
      LSIZEB = IB * PIXSIZE(DCODE)
      IPTRA  = 1
      IPTRB  = 1
      JPTR   = 1

      IF ( N .NE. MIN(N,IA,IB))  THEN
        ISTATUS = -1
        CALL XVMESSAGE('ERROR IN CROSSCORR4: INVALID N VALUE',' ')

      ELSE IF ( N .GT. MAXM_PAR .OR. M .GT. MAXM_PAR)  THEN
        ISTATUS = -1
        CALL XVMESSAGE('ERROR IN CROSSCORR4: INVALID M OR N VALUE',' ')

      ELSE
        IF (DCODE .EQ. 1 .OR. DCODE .EQ. 2 .OR. DCODE .EQ. 4)  THEN
          DO I = 1, M
            IF (FIRST)  THEN            ! MOVE A LINE AND CONVERT TO REAL*4.
               CALL FLOATA( DCODE, N, A(IPTRA), FA(JPTR) )
               IPTRA = IPTRA + LSIZEA
            END IF
            CALL FLOATA( DCODE, N, B(IPTRB), FB(JPTR) )
            IPTRB = IPTRB + LSIZEB
            JPTR = JPTR + N
          END DO

        ELSE IF (DCODE .EQ. 7 .OR. DCODE .EQ. 8)  THEN
          IF (DCODE .EQ. 7)  MCODE = 7
          IF (DCODE .EQ. 8)  MCODE =-9
          DO I = 1, M
            IF (FIRST)  THEN            ! MOVE A LINE.
               CALL MVE( MCODE, N, A(IPTRA), FA(JPTR),1,1 )
               IPTRA = IPTRA + LSIZEA
            END IF
            CALL MVE( MCODE, N, B(IPTRB), FB(JPTR),1,1 )
            IPTRB = IPTRB + LSIZEB
            JPTR = JPTR + N
          END DO

        ELSE
          ISTATUS = -1
          CALL XVMESSAGE('ERROR IN CROSSCORR4: INVALID DCODE VALUE',' ')
        END IF
      END IF

      IF (ISTATUS .EQ. 0)
     .  CALL FTCORR( FA,FB, M,N, FIRST, HPF, PHASE, PFILTER, OFFMAX,
     .               C, IL,IS, QUAL, ISTATUS)

      RETURN
      END

C********************************************************************
      SUBROUTINE CROSSCORR( A,IA, B,IB, M,N, DCODE, FIRST, HPF, PHASE,
     .                      PFILTER, OFFMAX,
     .                      C, IL,IS, QUAL, ISTATUS )
C  NAME OF ROUTINE
C      CROSSCORR (CROSS-CORRelation)
C  PREPARED FOR USE ON MIPL SYSTEM BY
C      STEVE POHORSKY   STERLING SOFTWARE        6-86
C  FOR
C      MIPL SOFTWARE DEVELOPMENT
C  ENVIRONMENT
C      VAX 11/780    VMS  with TAE/VICAR2 EXECUTIVE       FORTRAN-77
C
C  REVISION HISTORY
C
C  PROGRAM LIMITATIONS
C      SEE HLP FILE.
C  SUBROUTINES CALLED
C      FLOATA, FTCORR, MVE, QPRINT

      IMPLICIT NONE

C...ARGUMENT DECLARATIONS

      BYTE        A(*),B(*)
      INTEGER*4   IA, IB, M, N, DCODE, IL,IS, ISTATUS
      LOGICAL*4   FIRST, HPF
      REAL*4      PHASE, PFILTER, OFFMAX, C(N,M+2), QUAL

C...LOCAL DECLARATIONS

      INTEGER*4   I,  IPTRA,   IPTRB,   JPTR,   LSIZEA,  LSIZEB,
     .            MCODE,       MAXM_PAR,        MM2_PAR, PIXSIZE(8)

      PARAMETER   (MAXM_PAR = 256)       ! MAX FOR M & N.  COULD BE INCREASED.
      PARAMETER   (MM2_PAR  = MAXM_PAR*(MAXM_PAR+2))

      REAL*4      FA( MM2_PAR ), FB(MM2_PAR)
      SAVE        FA                     ! FFT OF A SLEPT HERE.

      DATA        PIXSIZE  /  1, 2, 0, 4, 0, 0, 4, 8  /  ! BYTES PER PIXEL

C
C======================START OF EXECUTABLE CODE======================

      ISTATUS = 0

C...CONVERT IMAGE DATA TO REAL*4 AND MOVE INTO FA & FB.

      LSIZEA = IA * PIXSIZE(DCODE)
      LSIZEB = IB * PIXSIZE(DCODE)
      IPTRA  = 1
      IPTRB  = 1
      JPTR   = 1

      IF ( N .NE. MIN(N,IA,IB))  THEN
        ISTATUS = -1
        CALL ifmessage('ERROR IN CROSSCORR: INVALID N VALUE')

      ELSE IF ( N .GT. MAXM_PAR .OR. M .GT. MAXM_PAR)  THEN
        ISTATUS = -1
        CALL ifmessage('ERROR IN CROSSCORR: INVALID M OR N VALUE')

      ELSE       ! automatch always uses decode = 7
        IF (DCODE .EQ. 1 .OR. DCODE .EQ. 2 .OR. DCODE .EQ. 4)  THEN
          DO I = 1, M
            IF (FIRST)  THEN            ! MOVE A LINE AND CONVERT TO REAL*4.
               CALL FLOATA( DCODE, N, A(IPTRA), FA(JPTR) )
               IPTRA = IPTRA + LSIZEA
            END IF
            CALL FLOATA( DCODE, N, B(IPTRB), FB(JPTR) )
            IPTRB = IPTRB + LSIZEB
            JPTR = JPTR + N
          END DO

        ELSE IF (DCODE .EQ. 7 .OR. DCODE .EQ. 8)  THEN
          IF (DCODE .EQ. 7)  MCODE = 7
          IF (DCODE .EQ. 8)  MCODE =-9   ! automatch always uses decode = 7
	  DO I=1, M
	      IF (FIRST) THEN                 ! MOVE A LINE
	        CALL MVE( MCODE, N, A(IPTRA), FA(JPTR),1,1 )
          	IPTRA = IPTRA + LSIZEA
              END IF
              CALL MVE( MCODE, N, B(IPTRB), FB(JPTR),1,1 )
              IPTRB = IPTRB + LSIZEB
              JPTR = JPTR + N
          END DO

        ELSE
          ISTATUS = -1
          CALL ifmessage('ERROR IN CROSSCORR: INVALID DCODE VALUE')
        END IF
      END IF

      IF (ISTATUS .EQ. 0)
     .  CALL FTCORR( FA,FB, M,N, FIRST, HPF, PHASE, PFILTER, OFFMAX,
     .               C, IL,IS, QUAL, ISTATUS)

      RETURN
      END

C********************************************************************
      SUBROUTINE FTCORR( FA,FB, M,N, FIRST, HPF, PHASE, PFILTER, OFFMAX,
     .                   C, IL,IS, QUAL, ISTATUS)

C#######################################################################
C  NAME OF ROUTINE
C      FTCORR (Fourier Transform cross-CORRelation)
C  PREPARED FOR USE ON MIPL SYSTEM BY
C      STEVE POHORSKY   STERLING SOFTWARE        6-86
C  FOR
C      MIPL SOFTWARE DEVELOPMENT
C  FTCORR descended from routine RFIT by K.F.Evans & routine FTCORR by L.W.Kamp.
C  ENVIRONMENT
C      VAX 11/780    VMS  with TAE/VICAR2 EXECUTIVE       FORTRAN-77
C
C  REVISION HISTORY
C
C  SUBROUTINES CALLED
C      RFT2, XVMESSAGE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      IMPLICIT NONE

C...ARGUMENT DECLARATIONS

      INTEGER*4   M, N, IL,IS, ISTATUS, ISTAT2
      LOGICAL*4   FIRST, HPF
      REAL*4      PHASE, PFILTER, OFFMAX, C(N,M+2), QUAL,
     .            FA(N,M+2), FB(N,M+2)

C...LOCAL DECLARATIONS

      INTEGER*4   I,  J,  IXMAX, JXMAX,  MHALF, NHALF

      REAL*4      DNORM,  FILPOW, POWER, POWERA, POWER1A,POWER1B,
     .            POWERB, POWER2A, POWER2B,  FILT, R2, Y2, AMP, AMPP,
     .            CIJR, CIJI, VMAX, T, RV
      SAVE        POWERA
C
C======================START OF EXECUTABLE CODE======================

      ISTATUS = 0
      DNORM   = MAX( M,N )
      DNORM   = 1./DNORM
C...CHECK THAT PARAMETERS ARE VALID.

      IF ( MOD(M,2) .NE. 0 .OR. MOD(N,2) .NE. 0 ) GO TO 8100
      IF ( PHASE .LT. 0 .OR. PHASE .GT. 1.0)      GO TO 8200
      IF ( PFILTER .LT. 0)                        GO TO 8300
      IF ( OFFMAX .LE. 0 .OR. OFFMAX .GT. 1.0)    GO TO 8400

C...FFT the image areas

      IF (FIRST)  THEN
          CALL RFT2(FA, M,N, 1, ISTAT2)
          IF (ISTAT2 .NE. 1) GO TO 8100

C...Do radial filter for A area

	  IF (PFILTER .NE. 0.0) THEN

	    IF (PHASE .EQ. 1.0) THEN
               FILPOW = PFILTER             ! ALL FOR A AND NONE FOR B.
            ELSE
               FILPOW = PFILTER/2.          ! HALF FOR A AND HALF FOR B.
            END IF

	    DO I = 1, N
	      Y2 = ( MIN(I-1, N-I+1)*DNORM )**2
	      DO J = 1, M+2, 2
	        R2 = Y2 + ( ((J-1)/2)*DNORM )**2
                IF (FILPOW .EQ. 1.0)  THEN
                   FILT = R2
                ELSE IF (FILPOW .EQ. .5)  THEN
                   FILT = SQRT(R2)
                ELSE
                   FILT = R2**FILPOW
                END IF
	        FA(I,J) = FILT*FA(I,J)
	        FA(I,J+1) = FILT*FA(I,J+1)
	      ENDDO
	    ENDDO
	  ENDIF

C...HANDLE FRACTIONAL PHASE VALUES.

          IF (PHASE .GT. 0.0 .AND. PHASE .LT. 1.0)  THEN
	    DO J = 1, M+2, 2
	      DO I = 1, N
	        AMP = AMAX1( SQRT( FA(I,J)**2 + FA(I,J+1)**2), 1.E-12)
                IF (PHASE .EQ. .5)  THEN
                    AMPP= 1./ SQRT(AMP)
                ELSE
                    AMPP= 1./( AMP**PHASE )
                END IF
	        FA(I,J)   = AMPP*FA(I,J)
	        FA(I,J+1) = AMPP*FA(I,J+1)
	      ENDDO
	    ENDDO
	  ENDIF

C		Zero first row and column if HPF

          IF (HPF) THEN
            CALL ZIA( FA, 2*N)
            DO J = 3,M+2
              FA(1,J) = 0.
            ENDDO
          ENDIF

C		Calculate power for normalization of nophase

	  IF (PHASE .NE. 1.0) THEN
	    FA(1,1) = 0.0               ! ZERO DIRECT CURRENT (DC) TERM.
	    FA(1,2) = 0.0    ! IN CASE NOT 0 BECAUSE OF ROUNDING.
            POWER1A = 0.0
            POWER2A = 0.0
            DO I = 1, N
      	      POWER1A = POWER1A + ( FA(I,1)**2 + FA(I,2)**2 )
      	      POWER1A = POWER1A + ( FA(I,M+1)**2 + FA(I,M+2)**2 )
              DO J = 3, M, 2
	        POWER2A = POWER2A + ( FA(I,J)**2 + FA(I,J+1)**2 )
              ENDDO
	    ENDDO
	    POWERA = POWER1A + 2*POWER2A
	  ENDIF
      ENDIF

C...COMPUTE FFT OF B IMAGE AREA.

      CALL RFT2(FB, M,N, 1, ISTAT2)
         IF (ISTAT2 .NE. 1) GO TO 8100

C...If phase corr. multiply FFT's  & divide by the amplitudes.

      IF (PHASE .EQ. 1.0)  THEN
        DO J = 1, M+1, 2
          DO I = 1, N
            CIJR = FA(I,J)*FB(I,J) + FA(I,J+1)*FB(I,J+1)
            CIJI = FA(I,J)*FB(I,J+1) - FA(I,J+1)*FB(I,J)
            AMP  = AMAX1( SQRT(CIJR*CIJR+CIJI*CIJI), 1.E-12)
            C(I,J)   = CIJR/AMP
            C(I,J+1) = CIJI/AMP
          ENDDO
        ENDDO

      ELSE   ! OTHERWISE WE FILTER AND COMPUTE NORMALIZATION FACTOR POWERB
             ! AND THEN MULTIPLY FFTS.

C...Do radial filter for B area

	  IF (PFILTER .NE. 0.0) THEN
            FILPOW = PFILTER/2.          ! HALF FOR A AND HALF FOR B.

	    DO I = 1, N
	      Y2 = ( MIN(I-1, N-I+1)*DNORM )**2
	      DO J = 1, M+2, 2
	        R2 = Y2 + ( ((J-1)/2)*DNORM )**2
                IF (FILPOW .EQ. 1.0)  THEN
                   FILT = R2
                ELSE IF (FILPOW .EQ. .5)  THEN
                   FILT = SQRT(R2)
                ELSE
                   FILT = R2**FILPOW
                END IF
	        FB(I,J) = FILT*FB(I,J)
	        FB(I,J+1) = FILT*FB(I,J+1)
	      ENDDO
	    ENDDO
	  ENDIF

C...HANDLE FRACTIONAL PHASE VALUES.

          IF (PHASE .GT. 0.0 .AND. PHASE .LT. 1.0)  THEN
	    DO J = 1, M+2, 2
	      DO I = 1, N
	        AMP = AMAX1( SQRT( FB(I,J)**2 + FB(I,J+1)**2), 1.E-12)
                IF (PHASE .EQ. .5)  THEN
                    AMPP= 1./ SQRT(AMP)
                ELSE
                    AMPP= 1./( AMP**PHASE )
                END IF
	        FB(I,J)   = AMPP*FB(I,J)
	        FB(I,J+1) = AMPP*FB(I,J+1)
	      ENDDO
	    ENDDO
	  ENDIF

C		Zero first row and column if HPF

          IF (HPF) THEN
            CALL ZIA( FB, 2*N)
            DO J = 3,M+2
              FB(1,J) = 0.
            ENDDO
          ENDIF

C		Calculate power for normalization.

	    FB(1,1) = 0.0               ! ZERO DIRECT CURRENT (DC) TERM.
	    FB(1,2) = 0.0    ! IN CASE NOT 0 BECAUSE OF ROUNDING.
            POWER1B = 0.0
            POWER2B = 0.0
            DO I = 1, N
      	      POWER1B = POWER1B + ( FB(I,1)**2 + FB(I,2)**2 )
      	      POWER1B = POWER1B + ( FB(I,M+1)**2 + FB(I,M+2)**2 )
              DO J = 3, M, 2
	        POWER2B = POWER2B + ( FB(I,J)**2 + FB(I,J+1)**2 )
              ENDDO
	    ENDDO
	    POWERB = POWER1B + 2*POWER2B

        DO J = 1, M+1, 2
          DO I = 1, N
            C(I,J)   = FA(I,J)*FB(I,J) + FA(I,J+1)*FB(I,J+1)
            C(I,J+1) = FA(I,J)*FB(I,J+1) - FA(I,J+1)*FB(I,J)
          ENDDO
        ENDDO

      ENDIF
C		FFT back to the image domain and rearrange
C			matrix to put the DC in center
      CALL RFT2(C, M,N, -1, ISTAT2)
          IF (ISTAT2 .NE. 1) GO TO 8100

      MHALF = M/2
      NHALF = N/2

      DO J = 1, MHALF
        DO I = 1, NHALF
          T = C(I,J)
          C(I,J) = C(I+NHALF,J+MHALF)
          C(I+NHALF,J+MHALF) = T
          T = C(I+NHALF,J)
          C(I+NHALF,J) = C(I,J+MHALF)
          C(I,J+MHALF) = T
        ENDDO
      ENDDO
C		Search for the correlation peak
      VMAX = C(1+NHALF, 1+MHALF)            ! INITIALIZE.
      IXMAX = 1 + NHALF
      JXMAX = 1 + MHALF
      DO J = 1, M
            DO I = 1, N
               RV = C(I,J)
               IF (VMAX .LT. RV) THEN
                  VMAX = RV
                  IXMAX = I
                  JXMAX = J
               ENDIF
            ENDDO
      ENDDO
C		Normalize the correlation value

      IF ( PHASE .EQ. 1.0 )  THEN
         IF (HPF)  THEN
            QUAL = VMAX/ ( (M-1)*(N-1) )
         ELSE
            QUAL = VMAX/ (M*N)
         END IF

      ELSE
         POWER = SQRT(POWERA*POWERB)
         IF (POWER .GT. 0.0)  THEN
            QUAL = VMAX/POWER
         ELSE
            QUAL = VMAX
         END IF
      ENDIF
C		Calculate the offsets.

      IL = JXMAX - MHALF - 1
      IS = IXMAX - NHALF - 1

C...Test for correlation peak too near edge of matrix.

      IF ( IABS(IL) .GT. OFFMAX*MHALF .OR. IABS(IS) .GT. OFFMAX*NHALF )
     .     ISTATUS = 2

7000  RETURN

C...ERROR HANDLING

8100  CONTINUE
      ISTATUS = -1
      CALL XVMESSAGE('ERROR IN FTCORR: INVALID M OR N VALUE',' ')
      GOTO 7000

8200  CONTINUE
      ISTATUS = -1
      CALL XVMESSAGE('ERROR IN FTCORR: INVALID PHASE VALUE',' ')
      GOTO 7000

8300  CONTINUE
      ISTATUS = -1
      CALL XVMESSAGE('ERROR IN FTCORR: INVALID PFILTER VALUE',' ')
      GOTO 7000

8400  CONTINUE
      ISTATUS = -1
      CALL XVMESSAGE('ERROR IN FTCORR: INVALID OFFMAX VALUE',' ')
      GOTO 7000

      END


! Based on version found in PySIT
! https://github.com/pysit/pysit/blob/master/pysit/solvers/constant_density_acoustic/time/scalar/constant_density_acoustic_time_scalar_2D_4.h

module scalar2d

        implicit none

contains

        subroutine step(f1, f2, phix1, phix2, phiy1, phiy2, sigmax,    &
                        sigmay, model2_dt2, dx, dt,                    &
                        sources, sources_x, num_steps,                 &
                        pml_width, step_ratio)

                real, intent (in out), dimension (:, :, :) :: f1
                real, intent (in out), dimension (:, :, :) :: f2
                real, intent (in out), dimension (:, :, :) :: phix1
                real, intent (in out), dimension (:, :, :) :: phix2
                real, intent (in out), dimension (:, :, :) :: phiy1
                real, intent (in out), dimension (:, :, :) :: phiy2
                real, intent (in), dimension (:) :: sigmax
                real, intent (in), dimension (:) :: sigmay
                real, intent (in), dimension (:, :) :: model2_dt2
                real, intent (in) :: dx
                real, intent (in) :: dt
                real, intent (in), dimension (:, :, :) :: sources
                integer, intent (in), dimension (:, :, :) :: sources_x
                integer, intent (in) :: num_steps
                integer, intent (in) :: pml_width
                integer, intent (in) :: step_ratio

                integer :: step_idx
                logical :: even
                real, dimension(2) :: fd_coeff1
                real, dimension(3) :: fd_coeff2

                fd_coeff1 = (/                                         &
                        8.0 / 12 / dx,                                 &
                        -1.0 / 12 / dx                                 &
                        /)
                fd_coeff2 = (/                                         &
                        -30.0 / 12 / dx**2 / 2,                        &
                        16.0 / 12 / dx**2,                             &
                        -1.0 / 12 / dx**2                              &
                        /)

                do step_idx = 1, num_steps * step_ratio
                even = (mod (step_idx, 2) == 0)
                if (even) then
                        call one_step(f2, f1, phix2, phix1, phiy2,     &
                                phiy1, sigmax, sigmay,                 &
                                model2_dt2,                            &
                                dt, sources, sources_x,                &
                                step_idx, fd_coeff1, fd_coeff2,        &
                                pml_width, step_ratio)
                else
                        call one_step(f1, f2, phix1, phix2, phiy1,     &
                                phiy2, sigmax, sigmay,                 &
                                model2_dt2,                            &
                                dt, sources, sources_x,                &
                                step_idx, fd_coeff1, fd_coeff2,        &
                                pml_width, step_ratio)
                end if
                end do

        end subroutine step

        subroutine one_step(f, fp, phix, phixp, phiy, phiyp, sigmax,   &
                        sigmay, model2_dt2, dt,                        &
                        sources, sources_x, step_idx,                  &
                        fd_coeff1, fd_coeff2, pml_width, step_ratio)

                real, intent (in), dimension (:, :, :) :: f
                real, intent (in out), dimension (:, :, :) :: fp
                real, intent (in out), dimension (:, :, :) :: phix
                real, intent (in out), dimension (:, :, :) :: phixp
                real, intent (in out), dimension (:, :, :) :: phiy
                real, intent (in out), dimension (:, :, :) :: phiyp
                real, intent (in), dimension (:) :: sigmax
                real, intent (in), dimension (:) :: sigmay
                real, intent (in), dimension (:, :) :: model2_dt2
                real, intent (in) :: dt
                real, intent (in), dimension (:, :, :) :: sources
                integer, intent (in), dimension (:, :, :) :: sources_x
                integer, intent (in) :: step_idx
                real, intent (in), dimension (2) :: fd_coeff1
                real, intent (in), dimension (3) :: fd_coeff2
                integer, intent (in) :: pml_width
                integer, intent (in) :: step_ratio

                integer :: x
                integer :: y
                integer :: s
                integer :: nx
                integer :: ny
                integer :: tpml1
                integer :: tpml2
                integer :: bpml1
                integer :: bpml2
                integer :: lpml1
                integer :: lpml2
                integer :: rpml1
                integer :: rpml2
                integer :: ix1
                integer :: ix2
                !integer :: iy1
                !integer :: iy2

                nx = size(f, dim=1)
                ny = size(f, dim=2)

                tpml1 = 3
                tpml2 = tpml1 + pml_width + 2

                bpml2 = ny - 2 !2
                bpml1 = bpml2 - pml_width - 2 !1

                lpml1 = 3
                lpml2 = lpml1 + pml_width + 2

                rpml2 = nx - 2 !2
                rpml1 = rpml2 - pml_width - 2 !1

                ix1 = lpml2 + 1
                ix2 = rpml1 - 1
                !iy1 = tpml2 + 1
                !iy2 = bpml2 - 1

                !$omp parallel do default(none) private(x)             &
                !$omp& shared(fd_coeff1, fd_coeff2, f, fp)             &
                !$omp& shared(model2_dt2, tpml1, tpml2, bpml1, bpml2)  &
                !$omp& shared(lpml1, lpml2, rpml1, rpml2, phix, phiy)  &
                !$omp& shared(phixp, phiyp, sigmax, sigmay, pml_width) &
                !$omp& shared(dt, ix1, ix2) collapse(2)
                do s = 1, ubound(fp, dim=3)
                do y = tpml1, bpml2
                if ((y <= tpml2) .or. (y >= bpml1)) then

                        do x = lpml1, rpml2
                        call fd_pml(f, fp, phix, phixp, phiy, phiyp,   &
                                sigmax, sigmay, model2_dt2, dt,        &
                                fd_coeff1, fd_coeff2, x, y, s)
                        end do

                else

                        do x = lpml1, lpml2
                        call fd_pml(f, fp, phix, phixp, phiy, phiyp,   &
                                sigmax, sigmay, model2_dt2, dt,        &
                                fd_coeff1, fd_coeff2, x, y, s)
                        end do

                        do x = ix1, ix2
                        call fd_inner(f, fp,                           &
                                model2_dt2,                            &
                                fd_coeff2, x, y, s)
                        end do

                        do x = rpml1, rpml2
                        call fd_pml(f, fp, phix, phixp, phiy, phiyp,   &
                                sigmax, sigmay, model2_dt2, dt,        &
                                fd_coeff1, fd_coeff2, x, y, s)
                        end do

                end if
                end do
                end do

                !$omp parallel do default(none)                        &
                !$omp& shared(fp, model2_dt2, sources, sources_x)&
                !$omp& shared(step_idx, step_ratio)
                do s = 1, ubound(fp, dim=3)
                call add_sources(fp, model2_dt2, sources,              &
                        sources_x, step_idx, step_ratio, s)
                end do

        end subroutine one_step

        subroutine add_sources(fp, model2_dt2, sources,                &
                        sources_x, step_idx, step_ratio, s)

                real, intent (in out), dimension (:, :, :) :: fp
                real, intent (in), dimension (:, :) :: model2_dt2
                real, intent (in), dimension (:, :, :) :: sources
                integer, intent (in), dimension (:, :, :) :: sources_x
                integer, intent (in) :: step_idx
                integer, intent (in) :: step_ratio
                integer, intent (in) :: s

                integer :: sx
                integer :: sy
                integer :: i
                integer :: num_sources

                num_sources = size(sources, dim=2)

                do i = 1, num_sources
                sx = sources_x(2, i, s) + 1
                sy = sources_x(1, i, s) + 1
                fp(sx, sy, s) = fp(sx, sy, s) +                        &
                        model2_dt2(sx, sy) *                           &
                        sources((step_idx-1)/step_ratio+1, i, s)
                end do

        end subroutine add_sources

        subroutine fd_inner(f, fp, model2_dt2,                         &
                        fd_coeff2, x, y, s)

                real, intent (in), dimension (:, :, :) :: f
                real, intent (in out), dimension (:, :, :) :: fp
                real, intent (in), dimension (:, :) :: model2_dt2
                real, intent (in), dimension (3) :: fd_coeff2
                integer, intent (in) :: x
                integer, intent (in) :: y
                integer, intent (in) :: s

                real :: lap

                lap = fd_coeff2(1) *                                   &
                        (f(x + 0, y, s) + f(x - 0, y, s) +             &
                        f(x, y + 0, s) + f(x, y - 0, s)) +             &
                        fd_coeff2(2) *                                 &
                        (f(x + 1, y, s) + f(x - 1, y, s) +             &
                        f(x, y + 1, s) + f(x, y - 1, s)) +             &
                        fd_coeff2(3) *                                 &
                        (f(x + 2, y, s) + f(x - 2, y, s) +             &
                        f(x, y + 2, s) + f(x, y - 2, s))

                fp(x, y, s) = model2_dt2(x, y) *                       &
                        lap +                                          &
                        2 * f(x, y, s) - fp(x, y, s)

        end subroutine fd_inner

        subroutine fd_pml(f, fp, phix, phixp, phiy, phiyp, sigmax,     &
                        sigmay, model2_dt2, dt, fd_coeff1,             &
                        fd_coeff2, x, y, s)

                real, intent (in), dimension (:, :, :) :: f
                real, intent (in out), dimension (:, :, :) :: fp
                real, intent (in), dimension (:, :, :) :: phix
                real, intent (in out), dimension (:, :, :) :: phixp
                real, intent (in), dimension (:, :, :) :: phiy
                real, intent (in out), dimension (:, :, :) :: phiyp
                real, intent (in), dimension (:) :: sigmax
                real, intent (in), dimension (:) :: sigmay
                real, intent (in) :: dt
                real, intent (in), dimension (:, :) :: model2_dt2
                real, intent (in), dimension (2) :: fd_coeff1
                real, intent (in), dimension (3) :: fd_coeff2
                integer, intent (in) :: x
                integer, intent (in) :: y
                integer, intent (in) :: s

                real :: lap
                real :: f_x
                real :: f_y
                real :: phix_x
                real :: phiy_y
                real :: sigma_sum
                real :: factor

                lap = fd_coeff2(1) *                                   &
                        (f(x + 0, y, s) + f(x - 0, y, s) +             &
                        f(x, y + 0, s) + f(x, y - 0, s)) +             &
                        fd_coeff2(2) *                                 &
                        (f(x + 1, y, s) + f(x - 1, y, s) +             &
                        f(x, y + 1, s) + f(x, y - 1, s)) +             &
                        fd_coeff2(3) *                                 &
                        (f(x + 2, y, s) + f(x - 2, y, s) +             &
                        f(x, y + 2, s) + f(x, y - 2, s))

                f_x = fd_coeff1(1) *                                   &
                        (f(x + 1, y, s) - f(x - 1, y, s)) +            &
                        fd_coeff1(2) *                                 &
                        (f(x + 2, y, s) - f(x - 2, y, s))

                f_y = fd_coeff1(1) *                                   &
                        (f(x, y + 1, s) - f(x, y - 1, s)) +            &
                        fd_coeff1(2) *                                 &
                        (f(x, y + 2, s) - f(x, y - 2, s))

                phix_x = fd_coeff1(1) *                                &
                        (phix(x + 1, y, s) - phix(x - 1, y, s)) +      &
                        fd_coeff1(2) *                                 &
                        (phix(x + 2, y, s) - phix(x - 2, y, s))

                phiy_y = fd_coeff1(1) *                                &
                        (phiy(x, y + 1, s) - phiy(x, y - 1, s)) +      &
                        fd_coeff1(2) *                                 &
                        (phiy(x, y + 2, s) - phiy(x, y - 2, s))

                sigma_sum = sigmax(x) + sigmay(y)
                factor = 1 / (1 + dt * sigma_sum / 2)

                fp(x, y, s) = factor * (model2_dt2(x, y) *             &
                        (lap + phix_x + phiy_y) +                      &
                        dt * sigma_sum * fp(x, y, s) / 2 +             &
                        (2 * f(x, y, s) - fp(x, y, s)) -               &
                        dt**2 * sigmax(x) * sigmay(y) * f(x, y, s))

                phixp(x, y, s) = phix(x, y, s) -                       &
                        dt * sigmax(x) * phix(x, y, s) -               &
                        dt * (sigmax(x) - sigmay(y)) * f_x
                phiyp(x, y, s) = phiy(x, y, s) -                       &
                        dt * sigmay(y) * phiy(x, y, s) -               &
                        dt * (sigmay(y) - sigmax(x)) * f_y

        end subroutine fd_pml

end module scalar2d


        SUBROUTINE GGAPSM ( fii, fji, npi, kx, ky, ismo,
     +			    iclsd, extend, fio, fjo, npo, iret )
C************************************************************************
C* GGAPSM                                                               *
C*                                                                      *
C* This subroutine takes a line (consisting of multiple segments) and	*
C* 1) performs smoothing of the line by adding points consistent with	*
C*    a parametric curve fitting algorithm, and				*
C* 2) adds endpoints to the line fording the ends to be outside the	*
C*    grid area.							*
C*                                                                      *
C* GGAPSM ( FII, FJI, NPI, KX, KY, ISMO, ICLSD, FIO, FJO, NPO, IRET )	*
C*                                                                      *
C* Input parameters:                                                    *
C*      FII (NPI)	REAL		I values in grid coords		*
C*      FJI (NPI)	REAL		J values in grid coords		*
C*	NPI		INTEGER		Number of points		*
C*      KX              INTEGER         Number of grid points in X      *
C*      KY              INTEGER         Number of grid points in Y      *
C*	ISMO		INTEGER		Smoothing factor		*
C*	ICLSD		INTEGER		Closed line indicator		*
C*                                                                      *
C* Output parameters:                                                   *
C*      FIO (NPO)	REAL		I values in grid coords		*
C*      FJO (NPO)	REAL		J values in grid coords		*
C*	NPO		INTEGER		Number of points		*
C*      IRET            INTEGER         Return code                     *
C**                                                                     *
C* Log:                                                                 *
C* D.W.Plummer/NCEP      9/98                                           *
C* D.W.Plummer/NCEP      9/98	Change calling sequence of CV_PRMT	*
C* W.D.Plummer/NCEP     12/02	Add GQCVSC call for device curve scale	*
C* W.D.Plummer/NCEP     07/03	Chg MAXPTS to MAXPPL			*
C* W.D.Plummer/NCEP     09/05	Add 'extend' param to calling seq 	*
C************************************************************************
C
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'grphgd.cmn'
C
        REAL            fii(*), fji(*), fio(*), fjo(*)
        LOGICAL		extend
C
	REAL		m
C*
	CALL GQCVSC ( dvcvsc, ier )
C
	dens = ismo
	IF ( ismo .eq. 2 )  dens = 5.0
	istrt = 0
	iend  = 0
	CALL CV_PRMT ( npi, fii, fji, dens, MAXPPL, dvcvsc,
     +		       istrt, iend, npo, fio, fjo, iret )
C
C*	Add point to starting endpoint iff inside grid area and
C*	curve is not closed AND the BNDS parameter blank
C
	IF ( extend )  THEN
C
	IF ( fio(1) .ge. 1 .and. fio(1) .le. kx  .and.
     +	     fjo(1) .ge. 1 .and. fjo(1) .le. ky  .and.
     +	     iclsd .eq. 0 )  THEN
C
	    IF ( fio(2) .eq. fio(1) )  THEN
		xnew = fio(1)
		IF ( fio(1) .lt. fio(2) )  THEN
		    ynew = 0.0
		ELSE
		    ynew = ky + 1.0
		END IF
	    ELSE
	        m = ( fjo(2) - fjo(1) ) / ( fio(2) - fio(1) )
	        b = fjo(1) - ( m * fio(1) )
		IF ( fio(1) .lt. fio(2) )  THEN
	            xnew = 0.0
		ELSE
	            xnew = kx + 1.0
		END IF
	        ynew = m * xnew + b
		IF ( ynew .gt. ky+1 )  THEN
		    ynew = ky + 1
		    xnew = ( ynew - b ) / m
		ELSE IF ( ynew .lt. 0 )  THEN
		    ynew = 0
		    xnew = ( ynew - b ) / m
		END IF
	    END IF
C
	    DO  n = npo, 1, -1
		fio(n+1) = fio(n)
		fjo(n+1) = fjo(n)
	    END DO
	    fio(1) = xnew
	    fjo(1) = ynew
C
	    npo = npo + 1
C
	END IF
C
C*	Add point to ending endpoint iff inside grid area and
C*	curve is not closed
C
	IF ( fio(npo) .ge. 1 .and. fio(npo) .le. kx  .and.
     +	     fjo(npo) .ge. 1 .and. fjo(npo) .le. ky  .and.
     +       iclsd .eq. 0 )  THEN
C
	    IF ( fio(npo-1) .eq. fio(npo) )  THEN
		xnew = fio(npo)
		IF ( fio(npo) .lt. fio(npo-1) )  THEN
		    ynew = 0.0
		ELSE
		    ynew = ky + 1.0
		END IF
	    ELSE
	        m = ( fjo(npo-1) - fjo(npo) ) / ( fio(npo-1) - fio(npo) )
	        b = fjo(npo) - ( m * fio(npo) )
		IF ( fio(npo) .lt. fio(npo-1) )  THEN
	            xnew = 0.0
		ELSE
	            xnew = kx + 1.0
		END IF
	        ynew = m * xnew + b
		IF ( ynew .gt. ky+1 )  THEN
		    ynew = ky + 1
		    xnew = ( ynew - b ) / m
		ELSE IF ( ynew .lt. 0 )  THEN
		    ynew = 0
		    xnew = ( ynew - b ) / m
		END IF
	    END IF
C
	    npo = npo + 1
	    fio(npo) = xnew
	    fjo(npo) = ynew
C
	END IF
C
	END IF
C
	RETURN
	END


      subroutine  splif(m,n,s,f,fp,fpp,fppp,km,vm,kn,vn,mode,fqm,ind)
c
c     ******************************************************************
c     *                                                                *
c     *   spline fit - jameson                                         *
c     *                                                                *
c     ******************************************************************
c
c     cubic spline fit of f(i) over s(i) from i = m to n.
c     m may be larger or smaller than n,
c     while s(i) may be increasing or decreasing,
c     as long as it continues in the same direction.
c     fp, fpp and fppp are the first, second and third derivatives of f.
c     vm and vn are end values at i = m and n
c     of the first, second or third derivatives of f,
c     depending on whether km or kn = 1,2 or 3.
c     the integral of f is placed in fppp if mode is greater than 0.
c     ind is set to zero if the data is illegal.
c
c     ******************************************************************
c
c     programmed by antony jameson july 1970 for the ibm 1130 computer.
c     revised december 2001 for fortran 95 compliance.
c
c     ******************************************************************
c
      dimension   s(*),f(*),fp(*),fpp(*),fppp(*)
c
c     ******************************************************************
c
      ind       = 0
      if (m.eq.n) return
      k         = sign(1,(n  -m))

      i         = m
      j         = m  +k
      ds        = s(j)  -s(i)
      d         = ds
      if (ds.eq.0.) return

      df        = (f(j)  -f(i))/ds

      if (km.le.1) then
         u         = .5
         v         = 3.*(df  -vm)/ds
      else if (km.eq.2) then
         u         = 0.
         v         = vm
      else
         u         = -1.
         v         = -ds*vm
      end if

      go to 21

   11 i         = j
      j         = j  +k
      ds        = s(j)  -s(i)
      if (d*ds.le.0.) return

      df        = (f(j)  -f(i))/ds
      b         = 1./(ds  +ds  +u)
      u         = b*ds
      v         = b*(6.*df  -v)

   21 fp(i)     = u
      fpp(i)    = v
      u         = (2.  -u)*ds
      v         = 6.*df  +ds*v

      if (j.ne.n) go to 11

      if (kn.le.1) then
         v         = (6.*vn  -v)/u
      else if (kn.eq.2) then
         v         = vn
      else
         v         = (ds*vn  +fpp(i))/(1.  +fp(i))
      end if

      b         = v
      d         = ds

   31 ds        = s(j)  -s(i)
      u         = fpp(i)  -fp(i)*v
      fppp(i)   = (v  -u)/ds
      fpp(i)    = u
      fp(i)     = (f(j)  -f(i))/ds  -ds*(v  +u  +u)/6.
      v         = u
      j         = i
      i         = i  -k

      if (j.ne.m) go to 31

      i         = n  -k
      fppp(n)   = fppp(i)
      fpp(n)    = b
      fp(n)     = df  +d*(fpp(i)  +b  +b)/6.
      ind       = 1

      if (mode.le.0) return
      fppp(j)   = fqm
      v         = fpp(j)

   41 i         = j
      j         = j  +k
      ds        = s(j)  -s(i)
      u         = fpp(j)
      fppp(j)   = fppp(i)  +.5*ds*(f(i)  +f(j)  -ds*ds*(u  +v)/12.)
      v         = u

      if (j.ne.n) go to 41

      return

      end


	FUNCTION PR_LATI  ( slat, slon, range, azim, selv )
C************************************************************************
C* PR_LATI 								*
C*                                                                      *
C* This function computes LATI given the range, azimuth and station	*
C* latitude, longitude and elevation.  Equations developed for use	*
C* in the AOIPS radar package are used.					*
C*									*
C* REAL PR_LATI  ( SLAT, SLON, RANGE, AZIM, SELV )			*
C*									*
C* Input parameters:                                                    *
C*	SLAT		REAL		Station latitude		*
C*	SLON		REAL   		Station longitude		*
C*	RANGE		REAL    	Range in kilometers		*
C*	AZIM		REAL   		Geographic azimuth in radians	*
C*	SELV		REAL		Station elevation		*
C*									*
C* Output parameters:                                                   *
C*	PR_LATI		REAL		Actual latitude			*
C**                                                                     *
C* Log:									*
C* M. desJardins/GSFC	 9/88	Made into function calling PR_RZLL	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C------------------------------------------------------------------------
C*	Call PR_RZLL to compute latitude/ longitude.
C
	CALL PR_RZLL  ( slat, slon, range, azim, selv, xlat, xlon,
     +			iret )
	PR_LATI = xlat
C*
	RETURN
	END


*DECK DGAMLM
      SUBROUTINE DGAMLM (XMIN, XMAX)
C***BEGIN PROLOGUE  DGAMLM
C***PURPOSE  Compute the minimum and maximum bounds for the argument in
C            the Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A, R2
C***TYPE      DOUBLE PRECISION (GAMLIM-S, DGAMLM-D)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Calculate the minimum and maximum legal bounds for X in gamma(X).
C XMIN and XMAX are not the only bounds, but they are the only non-
C trivial ones to calculate.
C
C             Output Arguments --
C XMIN   double precision minimum legal value of X in gamma(X).  Any
C        smaller value of X might result in underflow.
C XMAX   double precision maximum legal value of X in gamma(X).  Any
C        larger value of X might cause overflow.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DGAMLM
      DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH
C***FIRST EXECUTABLE STATEMENT  DGAMLM
      ALNSML = LOG(D1MACH(1))
      XMIN = -ALNSML
      DO 10 I=1,10
        XOLD = XMIN
        XLN = LOG(XMIN)
        XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML)
     1    / (XMIN*XLN+0.5D0)
        IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20
 10   CONTINUE
      CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2)
C
 20   XMIN = -XMIN + 0.01D0
C
      ALNBIG = LOG (D1MACH(2))
      XMAX = ALNBIG
      DO 30 I=1,10
        XOLD = XMAX
        XLN = LOG(XMAX)
        XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG)
     1    / (XMAX*XLN-0.5D0)
        IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40
 30   CONTINUE
      CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2)
C
 40   XMAX = XMAX - 0.01D0
      XMIN = MAX (XMIN, -XMAX+1.D0)
C
      RETURN
      END


program main
  !> prints a matrix quantity to screen for debug
  !  examples:
  !  call write_vector(vec, name='vector')
  !  call write_matrix(mat, name='matrix')
  !  call write_matrix(mat, name='packed matrix')
  !use print_matrix, only: write_matrix

  use build_box
  use algorithm
  implicit none

  intrinsic :: sqrt

  !> floating point accuracy
  integer, parameter :: wp = selected_real_kind(15)

  !> number of atoms
  integer, parameter :: natom = 108

  !> length of cubic box
  real(wp), parameter :: l = 17.158_wp

  !> atom coordinates of the system
  real(wp), dimension(3, natom) :: xyz

  !> forces
  real(wp), dimension(3, natom) :: f

  !> velocities
  real(wp), dimension(3, natom) :: v

  !> whatever
  real(wp), dimension(3, natom) :: a

  !> number of iterations
  integer, parameter :: itime = 200

  !> length of time step
  real(wp), parameter :: delta = 0.005_wp

  !> mass of particle
  real(wp), parameter :: mass = 39.948_wp

  !> temperature
  real(wp) :: T
  !> temperature to rescale velocities
  integer, parameter :: T_req = 8
  !> factor to rescale velocities
  real(wp) :: T_scaler

  !> potential energy
  real(wp) :: e_pot
  !> kinetic energy
  real(wp) :: e_kin
  !> total energy
  real(wp) :: e_tot

  !> iteration variables
  integer :: i, j, w

  ! initial temperature scaling (1 means no scaling)
  T_scaler = 1.0_wp

  ! initial velocities
  v = 0.0_wp

  ! pass 1 for sc and 4 for fcc
  call build_grid(xyz, natom, l, 4)

  ! evaluate forces and hence f/m from positions
  call calc_force(natom, xyz, f, l, e_pot)

  ! write energies
  open (unit=15, file="out/energy.csv")
  write (15, "(A22)") "time,e_kin,e_pot,e_tot"

  ! write trajectory for starting positions
  open (unit=16, file="out/trj.xyz")
  write (16, "(I3)") natom
  write (16, "(F15.8)") e_pot ! e_kin = 0 in first step (v = 0)
  do w = 1, natom
    write (16, *) "Ar", xyz(1, w), xyz(2, w), xyz(3, w)
  end do

  !*************************************************************
  !************************* MAIN LOOP *************************
  !*************************************************************

  main_loop: do i = 1, itime
    ! scale factor for velocities (skip first iteration because v = 0)
    if (i .gt. 1) then
      T = e_kin/1.5_wp/natom
      T_scaler = sqrt(T_req/T)
    end if

    do j = 1, natom
      ! scale and propagate velocities (half step)
      v(:, j) = T_scaler*(v(:, j) + 0.5_wp*f(:, j)/mass*delta)

      ! propagate positions
      xyz(:, j) = xyz(:, j) + v(:, j)*delta
    end do

    ! evaluate forces and hence f/m from positions
    call calc_force(natom, xyz, f, l, e_pot)

    do j = 1, natom
      ! propagate velocities again (half step) (no scaling?)
      v(:, j) = v(:, j) + 0.5_wp*f(:, j)/mass*delta
    end do

    call calc_e_kin(natom, v, mass, e_kin)
    e_tot = e_kin + e_pot

    ! write energies to console
    write (*, "(A16,2X,F15.8)") "Kinetic Energy =", e_kin
    write (*, "(A18,F15.8)") "Potential Energy =", e_pot
    write (*, "(A14,4X,F15.8)") "Total Energy =", e_tot

    ! write energies to file
    write (15, "(F15.8,A1,F15.8,A1,F15.8,A1,F15.8)") delta*i, ",", e_kin, ",", e_pot, ",", e_tot

    ! write trajectory
    write (16, "(I3)") natom
    write (16, "(F15.8)") e_tot
    do w = 1, natom
      write (16, *) "Ar", xyz(1, w), xyz(2, w), xyz(3, w)
    end do
  end do main_loop
end program main


! These routines provide the right-hand-side and a dummy jacobian for the
! DVODE solver.  More information about how ODE's can be found in the README
! file.
!
subroutine f_rhs(n, t, y, ydot, rpar, ipar)

  use bl_types

  implicit none

  integer,         intent(IN   ) :: n, ipar
  real(kind=dp_t), intent(IN   ) :: t, y(n), rpar
  real(kind=dp_t), intent(  OUT) :: ydot(n)

  call dydt(n, y, ydot)

  return

end subroutine f_rhs

subroutine jac(neq, t, y, ml, mu, pd, nrpd, rpar, ipar)

  use bl_types

  integer :: neq
  integer :: ml, mu, nrpd

  real(kind=dp_t) :: y(neq)
  real(kind=dp_t) :: pd(neq,neq)

  real(kind=dp_t) :: rpar
  integer :: ipar

  real(kind=dp_t) :: t

  return
end subroutine jac

subroutine dydt(n, y,ydot)

  use network
  use bl_types

  integer,            intent(IN   ) :: n
  real(kind=dp_t),    intent(IN   ) :: y(n)
  real(kind=dp_t),    intent(  OUT) :: ydot(n)

  integer :: i, j

  do i = 1, n

     ydot(i) = 0.0d0

     do j = 1, n

        ydot(i) = ydot(i) + y(j) * rates(i,j)

     enddo

  enddo

  return
end subroutine dydt


program tpslqm1

!   David H Bailey   22 May 2020

!  COPYRIGHT AND DISCLAIMER:
!    All software in this package (c) 2020 David H. Bailey.
!    By downloading or using this software you agree to the copyright, disclaimer
!    and license agreement in the accompanying file DISCLAIMER.txt.

!   This program demonstrates pslqm1, which performs the one-level multipair
!   PSLQ algorithm on an input vector.  A variety of sample input vectors can
!   be generated as inputs to pslqm1, as given in the parameters below.  The
!   pslqm1 routine is suitable for relations up to degree 25 or so; above this
!   level pslqm2 or pslqm3 should be used for significantly better performance.
!   For additional details, see:

!   David H. Bailey and David J. Broadhurst, "Parallel integer relation
!   detection: Techniques and applications," Mathematics of Computation,
!   vol. 70, no. 236 (Oct 2000), pg. 1719-1736, preprint available at
!   http://www.davidhbailey.com/dhbpapers/ppslq.pdf.

!   The pslqm1 routine is 100% THREAD SAFE -- all requisite parameters and
!   arrays are passed through subroutine arguments.

!   These parameters are set in parameter statements below:

!     itr   Number of trials when kq = 1, 2 or 3.  Default = 1.
!     kq    0: for the algebraic case [1, al, al^2, ... al^(n-1)], where
!             al = 3^(1/kr) - 2^(1/ks); this is the default.
!           1: for testing algebraic relations of a number read from a file.
!           2: for testing additive relations of numbers read from a file.
!           3: for testing multiplicative relations of numbers read from a file.
!           4: for custom input.
!     kr    Degree of root of 3 when kq = 0; default = 5.
!     ks    Degree of root of 2 when kq = 0; default = 6.
!     lcx   Size of character*1 array chr1; default = 64.
!           ***Must be a multiple of 64.  Must be <= lmx.
!           ***Must be > size in digits of largest result coefficient.

!   PSLQM3 parameters:
!     idb   Debug level (0-3); default = 2.
!     n     Integer relation vector length. When kq = 0, n = 1 + polynomial
!             degree; default for this program (when kq = 0) = kr * ks + 1 = 31.
!     ndp   Full precision level in digits; default for this program = 240.
!           ***Must be <= mpipl in module MPFUNF.
!           ***Must be >= ndpm + precision level required to find relation.
!     ndr   Log10 of the minimum dynamic range in y at detection; default = 20.
!             A detected relation is not deemed reliable unless this is exceeded.
!     nep   Log10 of full precision epsilon for detections; default = 20 - ndp.
!           ***Must not be smaller than the accuracy of input data. In other
!           words, if data is accurate to within 10^(-200), then nep > -200.
!     nrb   Log10 of maxinum size (Euclidean norm) of acceptable relation;
!             default = 200. Run will be aborted if this is exceeded.
!     nwds  Full precision level in words; default = int (ndp / mpdpw + 2).

use mpmodule
implicit none

integer itr, kq, kr, ks, lcx
parameter (itr = 1, kq = 0, kr = 5, ks = 6, lcx = 64)
integer idb, n, ndp, ndr, nep, nrb, nwds
parameter (idb = 2, n = kr * ks + 1, ndp = 240, ndr = 20, &
  nep = 20 - ndp, nrb = 200, nwds = int (ndp / mpdpw + 2))

real (8) d1, d2, m, second, tm, tm0, tm1
integer i, i1, iq, j, j1, k
integer lnm(n)
character(1) chr1(lcx)
character(64) form4, nam(n), namx
real (8) dr(n), r1(n)
type (mp_real) al, eps, t1, t2, r(n), x(n)
external second

!   Check to see if default precision is high enough.

if (ndp > mpipl) then
  write (6, '("Increase default precision in module MPFUNF.")')
  stop
endif

eps = mpreal (10.d0, nwds) ** nep
write (6, 1) itr, n, kq, kr, ks, ndr, nrb, ndp, nep
1 format ('PSLQM1 Test Program'/ &
  'No. trials = ',i3,3x,'n =',i4,3x,'kq =',i2/ &
  'kr =',i2,3x,'ks =',i2,3x,'ndr =',i5,3x,'nrb =',i5/ &
  'Full precision level ndp =',i6,' digits'/ &
  'Full precision epsilon level nep = ',i6)

if (kq == 1 .or. kq == 2 .or. kq == 3) then
  open (11, file = 'pslq.inp')
  rewind 11
endif

do k = 1, itr
  write (6, 2) k
2 format (/'Start trial', i3)

  if (kq == 0) then

!   This code generates al = 3^(1/kr) - 2^(1/ks).  al is algebraic of degree
!   kr * ks.  Set n = kr * ks + 1 to recover the polynomial satisfied by al.

    al = mpnrt (mpreald (3.d0, nwds), kr) - mpnrt (mpreald (2.d0, nwds), ks)
  elseif (kq == 1) then

!   Read an algebraic constant from a file.

    call mpread (11, al, nwds)
  elseif (kq == 2) then

!   Read constants from a file for additive test.

    do i = 1, n
      call mpread (11, al, nwds)
      x(i) = al
      write (namx, '(''con'',i3.3)') i
      nam(i) = namx(1:6)
      lnm(i) = 6
    enddo
  elseif (kq == 3) then

!   Read constants from a file for multiplicative test.

    do i = 1, n
      call mpread (11, al, nwds)
      x(i) = log (al)
      write (namx, '(''log(con'',i3.3,'')'')') i
      nam(i) = namx(1:11)
      lnm(i) = 11
    enddo
  elseif (kq == 4) then

!   Produce X vector by a custom scheme.

  endif

!   If kq is 0 or 1, generate x = [1, al, al^2, ..., al^(n-1)].

  if (kq == 0 .or. kq == 1) then
    x(1) = mpreald (1.d0, nwds)
    nam(1) = '1'
    lnm(1) = 1

    do i = 2, n
      x(i) = al * x(i-1)
      write (namx, '(''al^'',i3)') i - 1
      nam(i) = namx(1:6)
      lnm(i) = 6
    enddo
  endif

!   Perform relation search.

  tm0 = second ()
  call pslqm1 (idb, n, nwds, ndr, nrb, eps, x, iq, r)
  tm1 = second ()

!   Output relation, if one was found.

  if (iq == 1) then
    write (6, 3)
3   format (/'Recovered relation: 0 =')
    form4 = '(64a1'
    i1 = 5

    do i = 65, lcx, 64
      form4(i1+1:i1+9) =  '/64a1'
      i1 = i1 + 5
    enddo

    form4(i1+1:i1+9) = '," * ",a)'
    i1 = i1 + 9

    do i = 1, n
      if (r(i) .ne. 0.d0) then
        call mpfform (r(i), lcx, 0, chr1)

        do j = 1, lcx
          if (chr1(j) /= ' ') goto 120
        enddo

120     continue

        j1 = j
        if (chr1(j1) /= '-') then
          if (j1 > 1) then
            j1 = j1 - 1
            chr1(j1) = '+'
          else
            do j = 1, lcx
              chr1(j) = '*'
            enddo
          endif
        endif

        write (6, form4) (chr1(j), j = 1, lcx), nam(i)(1:lnm(i))
      endif
    enddo
  endif

  write (6, 6) tm1 - tm0
6 format ('CPU Time =',f12.4)
enddo

stop
end

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

!   The following code performs the one-level, multi-pair PSLQ algorithm.
!   David H. Bailey     22 May 2020

subroutine pslqm1 (idb, n, nwds, ndr, nrb, eps, x, iq, r)

!   Arguments are as follows:
!     Name  Type    Description
!     idb   int*4   Debug flag (0-3); increasing idb produces more output.
!     n     int*4   Length of input vector x and output relation r.
!     nwds  int*4   Full precision level in words. This must be sufficient
!                     to recover the relation.
!     ndr   int*4   Log10 of the min dynamic range at detection, typically 20
!                     or 30. A detected relation is not deemed reliable unless
!                     this is exceeded.
!     nrb   int*4   Log10 of max size (Euclidean norm) of acceptable relation,
!                     typically 100 or 200. Run will abort if this is exceeded.
!     eps   mp_real Tolerance for full precision relation detection. This is
!                     typically set to 2^(70-mpnbt*nwds) or so.
!     x     mp_real Input mp_real vector.
!     iq    int*4   Output flag: 0 (unsuccessful) or 1 (successful).
!     r     mp_real Output integer relation vector, if successful.

!   The following parameters are set in this routine:
!     ipi   int*4   Iteration print interval when idb >= 2; default = 100.
!     ipm   int*4   Iteration  check interval for MP iterations; default = 10.
!     itm   int*4   Maximum iteration count; default = 10^5. Run will be aborted
!                   if this is exceeded.
!     nsq   int*4   Size of tables used in iterdp and itermpw; default = 8.

use mpmodule
implicit none
integer i, idb, imq, ipi, ipm, iq, it, itm, izm, j, j1, n, ndr, nrb, &
  nwds, nsq, n1, n2, n3, n4
parameter (ipi = 25, ipm = 100, itm = 100000, nsq = 8)
real (8) d1, d2, d3, d4, dplog10, second, tm0, tm1, times(2)
real (8) dx(n)
type (mp_real) b(n,n), h(n,n), s(n), syq(n,nsq), r(n), x(n), &
  y(n), bound, dynrange, eps, rn, t1, t2, t3, t4
external bound, dplog10, dynrange, second

!   Initialize.

if (idb >= 2) write (6, 1) n
1 format ('PSLQM1 integer relation detection: n =',i5)
iq = 0
it = 0
imq = 0
rn = mpreal (0.d0, nwds)

do i = 1, 2
  times(i) = 0.d0
enddo

if (idb >= 2) write (6, 2) it
2 format ('Iteration',i8,2x,'MP initialization')
tm0 = second ()
call initmp (idb, n, nsq, nwds, b, h, syq, x, y)
tm1 = second ()
times(1) = tm1 - tm0

!   MP iterations.

if (idb >= 2) write (6, 3) it
3 format ('Iteration',i8,2x,'Start MP iterations')

100 continue

!   Perform one MP iteration.

it = it + 1
if (idb == 3 .or. idb >= 2 .and. mod (it, ipi) == 0) write (6, 4) it
4 format ('Iteration',i8)
tm0 = second ()
call itermp (idb, it, n, nsq, nwds, eps, b, h, syq, y, imq, izm)
tm1 = second ()
times(2) = times(2) + (tm1 - tm0)

!   Test conditions on itermp output flag izm:
!   0: MP update was uneventful; periodically output min, max, norm; continue.
!   1: A small value was found in MP update; go output relation.
!   2: Precision is exhausted; quit.

if (izm == 0) then

!   Periodically output min, max and norm.

  if (mod (it, ipm) == 0) then

!   Find min and max absolute value of y vector.

    call minmax (n, nwds, y, t1, t2)
    if (idb >= 2) then
      call decmd (t1, d1, n1)
      call decmd (t2, d2, n2)
      write (6, 5) it, d1, n1, d2, n2
5     format ('Iteration',i8,2x,'Min, max of y =',f11.6,'e',i6,f11.6,'e',i6)
    endif

!   Compute norm bound.

    t1 = bound (n, nwds, h)
    rn = max (rn, t1)
    if (idb >= 2) then
      call decmd (t1, d1, n1)
      call decmd (rn, d2, n2)
      write (6, 6) it, d1, n1, d2, n2
6     format ('Iteration',i8,2x,'Norm bound =',f11.6,'e',i5,4x,'Max. bound =', &
        f11.6,'e',i5)
    endif

!   Check if iteration limit or norm bound limit is exceeded; if so, quit.

    if (it > itm) then
      if (idb >= 1) write (6, 7) itm
7     format ('Iteration limit exceeded',i8)
      goto 120
    endif
    if (dplog10 (rn) > nrb) then
      if (idb >= 1) write (6, 8) nrb
8     format ('Norm bound limit exceeded.',i5)
      goto 120
    endif
  endif
  goto 100
elseif (izm == 1) then
  goto 110
elseif (izm == 2) then
  goto 120
endif

110 continue

!   A relation has been detected.

tm0 = second ()
t1 = mpreald (1.d300, nwds)
t2 = mpreal (0.d0, nwds)
t3 = mpreal (0.d0, nwds)

!   Select the relation corresponding to the smallest y entry and compute norm.

do j = 1, n
  if (abs (y(j)) < t1) then
    j1 = j
    t1 = abs (y(j))
  endif
  t2 = max (t2, abs (y(j)))
enddo

do i = 1, n
  r(i) = b(j1,i)
  t3 = t3 + r(i) ** 2
enddo

t3 = sqrt (t3)
call decmd (t3, d3, n3)
d3 = d3 * 10.d0 ** n3

!   Output the final norm bound and other info.

if (idb >= 1) then
  t4 = bound (n, nwds, h)
  call decmd (t1, d1, n1)
  call decmd (t2, d2, n2)
  call decmd (t3, d3, n3)
  call decmd (t4, d4, n4)
  write (6, 9) it, d1, n1, d2, n2, d4, n4
9 format ('Iteration',i8,2x,'Relation detected'/ &
  'Min, max of y =',0p,f11.6,'e',i5,f11.6,'e',i5/'Max. bound =',f11.6,'e',i5)
  write (6, 10) j1, d3, n3, d1, n1
10 format ('Index of relation =',i4,3x,'Norm =',f11.6,'e',i5,3x, &
  'Residual =',f11.6,'e',i5)
endif

!   If run was successful, set iq = 1.

if (n3 <= nrb .and. n2 - n1 >= ndr) then
  iq = 1
else
  if (idb >= 2) write (6, 11)
11 format ('Relation is too large or insufficient dynamic range.')
endif

120 continue

!   Output CPU run times and return.

if (idb >= 2) write (6, 12) times
12 format ('CPU times:'/(5f12.2))

return
end

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

!   First-level subroutines.

subroutine minmax (n, nwds, y, y1, y2)

!   This returns min|y_k| and max|y_k| using MP precision.
!   Input: n, nwds, y.
!   Output: y1, y2.

use mpmodule
implicit none
integer i, n, n1, nwds
real (8) d1
type (mp_real) dynrange, t1, t2, t3
type (mp_real) y(n), y1, y2

t1 = mpreald (1.d300, nwds)
t2 = mpreald (0.d0, nwds)

!   Find the min and max absolute value in the y vector.

do i = 1, n
  t3 = abs (mpreal (y(i), nwds))
  t1 = min (t1, t3)
  t2 = max (t2, t3)
enddo

y1 = t1
y2 = t2
return
end

subroutine initmp (idb, n, nsq, nwds, b, h, syq, x, y)

!   This initializes MP arrays at the beginning.
!   This is performed in full precision.
!   Input: idb, n, nsq, nwds.
!   Output: b, h, syq, x, y.

use mpmodule
implicit none
integer i, i1, idb, j, n, nsq, nwds
real (8) d1
integer ix(n)
real (8) dx(n)
type (mp_real) b(n,n), h(n,n), s(n), syq(n,nsq), x(n), y(n), t1, t2

if (idb >= 3) then
  write (6, 1)
1 format ('initmp: Input x vector:')
  call matoutmd (1, n, ix, dx, x)
endif

!   Set b to the identity matrix.

do j = 1, n
  do i = 1, n
    b(i,j) = mpreal (0.d0, nwds)
  enddo

  b(j,j) = mpreal (1.d0, nwds)
enddo

t1 = mpreal (0.d0, nwds)

!   Compute the x vector, the square root of the partial sum of squares of x,
!   and the y vector, which is the normalized x vector.

do i = n, 1, -1
  t1 = t1 + x(i) ** 2
  s(i) = sqrt (t1)
enddo

t1 = 1.d0 / s(1)

do i = 1, n
  y(i) = t1 * x(i)
  s(i) = t1 * s(i)
enddo

!   Compute the initial h matrix.

do j = 1, n - 1
  do i = 1, j - 1
    h(i,j) = mpreal (0.d0, nwds)
  enddo

  h(j,j) = s(j+1) / s(j)
  t1 = y(j) / (s(j) * s(j+1))

  do i = j + 1, n
    h(i,j) = - y(i) * t1
  enddo
enddo

!   Zero the syq array.

do j = 1, nsq
  do i = 1, n
    syq(i,j) = mpreal (0.d0, nwds)
  enddo
enddo

if (idb >= 3) then
  write (6, 2)
2 format ('initmp: Initial y vector:')
  call matoutmd (1, n, ix, dx, y)
  write (6, 3)
3 format ('initmp: Initial h matrix:')
  call matoutmd (n, n - 1, ix, dx, h)
endif

return
end

subroutine itermp (idb, it, n, nsq, nwds, eps, b, h, syq, y, imq, izm)

!   This performs one iteration of the PSLQM algorithm using MP arithmetic.
!   This is performed in medium precision.
!   Input: idb, it, n, nsq, nwds, eps, imq.
!   Output: b, h, syq, y, imq, izm.

use mpmodule
implicit none
integer i, idb, ii, ij, im, im1, imq, it, izm, j, j1, j2, k, mpr, mq, n, &
  n1, nsq, ntl, nwds
parameter (ntl = 72)
real (8) d1, d2
integer ip(n), ir(n), is(n)
real (8) dx(n)
type (mp_real) b(n,n), h(n,n), q(n), syq(n,nsq), t(n,n), y(n)
type (mp_real) eps, gam, t1, t2, t3, t4, teps

teps = 2.d0 ** ntl * eps
izm = 0
mpr = nint (0.4d0 * n)
gam = sqrt (mpreald (4.d0, nwds) / mpreald (3.d0, nwds))

!   Compute q vector = {gam^i * |h(i,i)|}, then sort in ascending order.

do i = 1, n - 1
  q(i) = gam ** i * abs (h(i,i))
enddo

call qsortmp (n - 1, q, ip)

!   Select up to mpr disjoint pairs of indices (m,m+1), where m is an index
!   from the list of the largest q(i).

do i = 1, n
  is(i) = 0
enddo

if (imq == 0) then
  mq = mpr
else
  mq = 1
  imq = 0
endif
ii = n

do i = 1, mq
100 continue
  ii = ii - 1
  if (ii == 0) then
    mq = i - 1
    goto 110
  endif
  j1 = ip(ii)
  j2 = j1 + 1
  if (is(j1) .ne. 0 .or. is(j2) .ne. 0) goto 100
  ir(i) = j1
  is(j1) = 1
  is(j2) = 1
enddo

110 continue

!   Exchange the pairs of entries of y, and rows of b and h.

do j = 1, mq
  im = ir(j)
  im1 = im + 1
  t1 = y(im)
  y(im) = y(im1)
  y(im1) = t1

  do i = 1, n
    t1 = b(im,i)
    b(im,i) = b(im1,i)
    b(im1,i) = t1
  enddo

  do i = 1, n - 1
    t1 = h(im,i)
    h(im,i) = h(im1,i)
    h(im1,i) = t1
  enddo
enddo

!   Eliminate the "corners" produced by the above permutation in h.

do j = 1, mq
  im = ir(j)
  im1 = im + 1
  if (im <= n - 2) then
    t1 = h(im,im)
    t2 = h(im,im1)
    t3 = sqrt (t1 ** 2 + t2 ** 2)
    t1 = t1 / t3
    t2 = t2 / t3

    do i = im, n
      t3 = h(i,im)
      t4 = h(i,im1)
      h(i,im) = t1 * t3 + t2 * t4
      h(i,im1) = - t2 * t3 + t1 * t4
    enddo
  endif
enddo

!   Perform reduction on h, using the diagonal scheme.  Multipliers are
!   saved in the t array.

do i = 2, n
  do j = 1, n - i + 1
    ij = i + j - 1

    do k = j + 1, ij - 1
      h(ij,j) = h(ij,j) - t(ij,k) * h(k,j)
    enddo

    t(ij,j) = anint (h(ij,j) / h(j,j))
    h(ij,j) = h(ij,j) - t(ij,j) * h(j,j)
  enddo
enddo

!   Update y, using the t array.  Find min absolute value of y.

t1 = abs (y(n))
j1 = n

do j = 1, n - 1
  do i = j + 1, n
    y(j) = y(j) + t(i,j) * y(i)
  enddo

  if (abs (y(j)) < t1) then
    j1 = j
    t1 = abs (y(j))
  endif
enddo

!   Update b, using the t array.

do k = 1, n
  do j = 1, n - 1
    do i = j + 1, n
      b(j,k) = b(j,k) + t(i,j) * b(i,k)
    enddo
  enddo
enddo

!  Find the largest entry of b in the same row as the smallest y.

t2 = mpreal (0.d0, nwds)

do i = 1, n
  t2 = max (t2, abs (b(j1,i)))
enddo

if (t1 <= t2 * teps) then
  if (idb >= 2) then
    call decmd (t1, d1, n1)
    write (6, 1) it, d1, n1
1   format ('Iteration',i8,2x,'itermp: Small value in y =',f11.6,'e',i5)
  endif
  if (t1 <= t2 * eps) then
    izm = 1
  else
    if (idb >= 1) write (6, 2) it
2   format ('Iteration',i8,2x,'itermp: Precision exhausted.')
    izm = 2
  endif
endif

!   Compare the y vector with those of recent iterations.  If a duplicate is
!   found, then the next iteration must be performed with mq = 1.

do j = 1, nsq
  t1 = mpreal (0.d0, nwds)

  do i = 1, n
    t1 = max (t1, abs (y(i) - syq(i,j)))
  enddo

  if (t1 <= t2 * teps) then
    if (idb >= 2) write (6, 3) it, j
 3  format ('Iteration',i8,2x,'itermp: Duplicate found, j =',i6)
    imq = 1
    goto 120
  endif
enddo

!   Place the vector y in the table syq.

120 continue

k = 1 + mod (it, nsq)

do i = 1, n
  syq(i,k) = y(i)
enddo

if (idb >= 3) then
  write (6, 4)
4 format ('itermp: Updated y:')
!  call matoutmd (1, n, ip, dx, y)
  call matoutmp (1, n, y)
  write (6, 5)
5 format ('itermp: Updated b matrix:')
  call matoutmd (n, n, ip, dx, b)
  write (6, 6)
6 format ('itermp: Updated h matrix:')
  call matoutmd (n, n - 1, ip, dx, h)
endif

return
end

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

!   Second- and third-level subroutines.

function bound (n, nwds, h)

!   This computes the norm bound using MP arithmetic.

use mpmodule
implicit none
integer i, n, nwds
type (mp_real) bound,  h(n,n), t1, t2

t1 = mpreal (0.d0, nwds)

do i = 1, n - 1
  t1 = max (t1, abs (h(i,i)))
enddo

bound = 1.d0 / t1

return
end

function dplog10 (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use mpmodule
implicit none
integer ia
real (8) da, dplog10, t1
type (mp_real) a

call mpmdi (a, da, ia)
if (da == 0.d0) then
  dplog10 = -999999.d0
else
  dplog10 = log10 (abs (da)) + ia * log10 (2.d0)
endif

100 continue
return
end

subroutine decmd (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodule
implicit none
integer ia, ib
real (8) da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (mp_real) a

call mpmdi (a, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 < 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end

subroutine matoutmd (n1, n2, ix, dx, a)

!   This outputs the MP matrix a as a DP matrix.

use mpmodule
implicit none
integer i, j, n1, n2
integer ix(n2)
real (8) dx(n2)
type (mp_real) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call decmd (a(i,j), dx(j), ix(j))
  enddo

  write (6, 2) (dx(j), ix(j), j = 1, n2)
2 format (4(f13.8,'e',i5))
enddo

return
end

subroutine matoutmp (n1, n2, a)

!   This outputs the MP matrix a.  It may be used in place of calls to matoutmd
!   in the code above if greater accuracy is desired in debug output.

use mpmodule
implicit none
integer i, j, n1, n2
type (mp_real) a(n1,n2)

do i = 1, n1
  write (6, 1) i
1 format ('Row',i3)

  do j = 1, n2
    call mpwrite (6, 80, 60, a(i,j))
  enddo
enddo

return
end

subroutine qsortmp (n, a, ip)

!   This routine sorts the entries of the N-long MP vector A into ascending
!   order using the quicksort algorithm.  The permutation vector that would
!   sort the vector is returned in IP.
!   Input: n, a.
!   Output: ip.

use mpmodule
implicit none
integer i, iq, it, j, jq, jz, k, l, n
integer ip(n), ik(50), jk(50)
type (mp_real) a(n), s0, s1, s2

do i = 1, n
  ip(i) = i
enddo

if (n == 1) return

k = 1
ik(1) = 1
jk(1) = n

130 continue

i = ik(k)
j = jk(k)
iq = i
jq = j
it = (i + j + 1) / 2
l = ip(j)
ip(j) = ip(it)
ip(it) = l
s0 = a(ip(j))
j = j - 1

140 continue

do l = i, j
  if (s0 < a(ip(l))) goto 160
enddo

i = j
goto 190

160 continue

i = l

do l = j, i, -1
  if (s0 > a(ip(l))) goto 180
enddo

j = i
goto 190

180 continue

j = l
if (i >= j) goto 190
l = ip(i)
ip(i) = ip(j)
ip(j) = l
goto 140

190 continue

if (s0 >= a(ip(i))) goto 200
l = ip(jq)
ip(jq) = ip(i)
ip(i) = l

200 continue

k = k - 1
jz = 0
if (j == iq) goto 210
k = k + 1
jk(k) = j
jz = 1

210 continue

i = i + 1
if (i == jq) goto 220
k = k + 1
ik(k) = i
jk(k) = jq
if (jz == 0) goto 220
if (j - iq >= jq - i) goto 220
ik(k-1) = i
jk(k-1) = jq
ik(k) = iq
jk(k) = j

220 continue

if (k > 0) goto 130

return
end


      SUBROUTINE DPRTLS( ISUB, SUBNAM, NDATA, NM, MVAL, NN, NVAL,
     $                   NNS, NSVAL, NNB, NBVAL, NXVAL, NLDA, LDAVAL,
     $                   MTYPE, RSLTS, NOUT )
*
*  -- LAPACK timing routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER*6        SUBNAM
      INTEGER            ISUB, MTYPE, NDATA, NLDA, NM, NN, NNB,
     $                   NNS, NOUT
*     ..
*     .. Array Arguments ..
      INTEGER            LDAVAL( * ), MVAL( * ), NBVAL( * ),
     $                   NSVAL( * ), NVAL( * ), NXVAL( * )
      DOUBLE PRECISION   RSLTS( 6, 6, * )
*     ..
*
*  Purpose
*  =======
*
*  DPRTLS prints a table of timing data for the least squares routines.
*
*  Arguments
*  =========
*
*  ISUB    (input) INTEGER
*          Subroutine index.
*
*  SUBNAM  (input) CHARACTER*6
*          Subroutine name.
*
*  NDATA   (input) INTEGER
*          Number of components for subroutine SUBNAM.
*
*  NM      (input) INTEGER
*          The number of values of M contained in the vector MVAL.
*
*  MVAL    (input) INTEGER array, dimension (NM)
*          The values of the matrix row dimension M.
*
*  NN      (input) INTEGER
*          The number of values of N contained in the vector NVAL.
*
*  NVAL    (input) INTEGER array, dimension (NN)
*          The values of the matrix column dimension N.
*
*  NNS     (input) INTEGER
*          The number of values of NRHS contained in the vector NSVAL.
*
*  NSVAL   (input) INTEGER array, dimension (NNS)
*          The values of the number of right hand sides NRHS.
*
*  NNB     (input) INTEGER
*          The number of values of NB and NX contained in the
*          vectors NBVAL and NXVAL.  The blocking parameters are used
*          in pairs (NB,NX).
*
*  NBVAL   (input) INTEGER array, dimension (NNB)
*          The values of the blocksize NB.
*
*  NXVAL   (input) INTEGER array, dimension (NNB)
*          The values of the crossover point NX.
*
*  NLDA    (input) INTEGER
*          The number of values of LDA contained in the vector LDAVAL.
*
*  LDAVAL  (input) INTEGER array, dimension (NLDA)
*          The values of the leading dimension of the array A.
*
*  MTYPE   (input) INTEGER
*          Number of matrix types.
*
*  RSLTS   (workspace) DOUBLE PRECISION array
*          dimension( 6, 6, number of runs )
*
*  NOUT    (input) INTEGER
*          The unit number for output.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            ICASE, IDATA, ILDA, IM, IN, INB, INS,
     $                   ITYPE, LDA, M, N, NB, NRHS, NX
*     ..
*     .. Executable Statements ..
*
      ICASE = 1
*
      DO 70 IM = 1, NM
         M = MVAL( IM )
         DO 60 IN = 1, NN
            N = NVAL( IN )
            DO 50 INS = 1, NNS
               NRHS = NSVAL( INS )
               DO 40 ILDA = 1, NLDA
                  LDA = MAX( 1, LDAVAL( ILDA ) )
                  IF( ISUB.EQ.2 ) THEN
                     WRITE( NOUT, FMT = 9999 ) M, N, NRHS, LDA
                     WRITE( NOUT, FMT = 9998 ) SUBNAM, ( IDATA,
     $                    IDATA = 1, NDATA-1 )
                     DO 10 ITYPE = 1, MTYPE
                        WRITE( NOUT, FMT = 9997 ) ITYPE,
     $                       ( RSLTS( IDATA, ITYPE, ICASE ),
     $                       IDATA = 1, NDATA )
   10                CONTINUE
                     ICASE = ICASE + 1
                  ELSE
                     DO 30 INB = 1, NNB
                        NB = NBVAL( INB )
                        NX = NXVAL( INB )
                        WRITE( NOUT, FMT = 9996 ) M, N, NRHS, LDA,
     $                       NB, NX
                        WRITE( NOUT, FMT = 9998 ) SUBNAM, ( IDATA,
     $                       IDATA = 1, NDATA-1 )
                        DO 20 ITYPE = 1, MTYPE
                           WRITE( NOUT, FMT = 9997 ) ITYPE,
     $                          ( RSLTS( IDATA, ITYPE, ICASE ),
     $                          IDATA = 1, NDATA )
   20                   CONTINUE
                        ICASE = ICASE + 1
   30                CONTINUE
                  END IF
   40          CONTINUE
   50       CONTINUE
   60    CONTINUE
   70 CONTINUE
*
 9999 FORMAT( / ' M = ', I5, ', N = ', I5, ', NRHS = ', I5,
     $        ', LDA = ', I5 )
 9998 FORMAT( / ' TYPE ', 4X, A6, 1X, 8( 4X, 'comp.', I2, : ) )
 9997 FORMAT( I5, 2X, 1P, 6G11.2 )
 9996 FORMAT( / ' M = ', I5, ', N = ', I5, ', NRHS = ', I5,
     $        ', LDA = ', I5, ', NB = ', I3, ', NX = ', I3 )
      RETURN
*
*     End of DPRTLS
*
      END


C     non unit loop increment.
C
      program INCR3
      integer I, A(12)
      do I = 1,10,3
         A(I) = 1
         A(I+1) = 2
         A(I+2) = 3
      enddo
      print *, A
      end