$nofloatcalls
$LARGE R
$storage:2
C REGGE.FOR 3/18/85 - DOUG WHITE'S REGULAR EQUIVALENCE PROGRAM
C  THIS VERSION ALLOWS USER TO SET THE NUMBER OF ITERATIONS 
C  FIRST ITERATION IS WRITTEN ON OUTPUT FILE REGGOUT1
C  FINAL ITERATION IS WRITTEN ON OUTPUT FILE REGGOUT
C
      DIMENSION  IN (90), DEG (90), SUM (90,90)
      COMMON R (90,90, 2), B (90,90), N, NR
      character*12 FILE
      character*5 names
C AN INTERACTIVE MODE IS CREATED:
      write (*,8900)
8900  format (/,/,/,12x,24('*'),'UCINET',24('*'),/,12x,'*',52x,'*',/,
     +12x,'*',22x,'R E G E',23x,'*',/,12x,'*',52x,'*',/,12x,54('*'),/,/)
      OPEN (4,FILE='CON:',STATUS='OLD')
      OPEN (21,FILE='CON:',STATUS='OLD')
      WRITE (4,'(a,\)') ' HOW MANY FILES DO YOU WANT TO STACK? '
      read(*,'(i1)') NR
      write (*,'(a\)') ' NUMBER OF ITERATIONS? '
      read(*,'(i1)') ITER
      write (*,8992)
8992  format (' CHOOSE AN INITIAL EQUIVALENCE RELATION ',/,
     + ' 1. <default> Universal (Regular Equivalence)',/,
     + ' 2. READ A LOWER RECTANGULAR FILE',/,
     + ' 3. Identity (Sailer`s Structural Resemblance)')
      read (*,'(i1)') INEQ
      if (ineq .ne. 2) goto 5
      write (*,'(a\)') ' NAME OF EQUIVALENCE FILE? '
      read (*,'(A)') FILE
C THE EQUIVALENCE FILE IS OPENED
      OPEN (7, FILE=FILE)
 5    IQUIT=0
C   N = # NODES     NR = # RELATIONS,   ITER > 5   NOERRS, CUT

      DO 10 KR=1,NR
      WRITE (4,9994) kr
9994  FORMAT (/,' HEADER FILE NAME (on default DRIVE) for FILE ',
     + i1,'? ',\)
      read (*,'(A)') FILE
C THE HEADER FILE IS OPENED
      OPEN (20, FILE=FILE)
      READ (20,*) ia, N, n2
      READ (20,'(a)') Names 
      READ (20,'(a)') FILE
      CLOSE (20)
C THE DATA FILE IS OPENED
      OPEN (20, FILE=FILE)
C STACKED RELATION MATRICES ARE READ
      DO 9 I=1,N
   9  READ (20,*) (r(I,J,kr),J=1,N)
  10  CLOSE (20)
 
C     COMPUTE DEGREE, SUMS FOR I-->K, INITIAL STRUCTURAL EQUIV.
      DO 100 I=1,N
      DEG(I)=0.0
      DO 100 J=1,N
      SUM(I,J)=0.0
      DO 50 KR=1,NR
   50 SUM(I,J)=SUM(I,J)+R(I,J,KR)+R(J,I,KR)
  100 DEG(I)=DEG(I)+SUM(I,J)

C     B = 1 WHEN I & J HAVE NO DEGREE
      B(1,1)=1.0
      DO 150 I=2,N
      B(I,I)=1.0
      if (ineq .eq. 2) read (7,901) (in(j), j=1,i-1)
      DO 150 J=1,I-1
      B(I,J)=0.0
      IF(DEG(I)*DEG(J).EQ.0.0) B(I,J) = 1.0
      IF (INEQ .NE. 3) B(I,J) = 1.0
  150 IF (INEQ .EQ. 2) B(I,J) = REAL(IN (J))/100.

      OPEN (5,FILE='REGGOUT.DAT',STATUS='new')
      IF (ITER .NE. 1) OPEN (6,FILE='REGGOUT1.DAT',STATUS='new')
      write (*,'(a)') ' 1st ITERATION ON FILE "REGGOUT1.DAT" '
      write (*,'(a)') ' Final ITERATION  FILE "REGGOUT.DAT" '

C     BEGIN ITERATIONS
      DO 700 L=1,ITER
      WRITE(21,160) L
  160 FORMAT(10H ITERATION   , I3)
C     INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES
      D = 0.0
C     TAKE POINT I
      DO 520 II = 1, N-1
      I=II
C     IF DEGREE ZERO NEXT I
      IF(DEG(I).EQ.0.0) GO TO 520
C     TAKE POINT J
      DO 510 JJ= II+1, N
      CM      = 0.0
      J=JJ
C     IF DEGREE ZERO NEXT J
      IF(DEG(J).EQ.0.0) GO TO 506
      I=II
C TAKE EACH OF THE TWO POINTS AS REFERENT
      DO 505 IJ=1,2
      IF (IJ.EQ.1) GOTO 120
      J=II
      I=JJ
C     TAKE POINT K (I-->K, K-->I TO BE EXAMINED)
 120  DO 500 K=1,N
      IF(SUM(I,K).EQ.0.0) GO TO 500
      XMAX=0.0
C     FIND BEST MATCHING POINT M
      DO 400 M=1,N
      IF(SUM(J,M).EQ.0.0) GO TO 400
      SUMM=0.0
      DO 300 KR=1,NR
  300 SUMM = SUMM +min (R(I,K,KR),r(j,m,kr)) +min (R(K,I,KR),r(m,j,kr))
      CMIKJM = SUMM * b (max (k,m), min (k,m))
C     IF PERFECT MATCH DESIRED, CORRECT MATCH
c     IF(SUMM.NE.SUM(I,K).AND.NOERRS.EQ.1)  CMIKJM=0.0
      IF(CMIKJM.GT.XMAX) XMAX= CMIKJM
 
      IF(XMAX.EQ.SUM(I,K)) GO TO 450
 
  400 CONTINUE
C     ADD BEST MATCHES TO REGULAR EQUIVALENCE NUMERATOR FOR I,J
  450 CM=CM+XMAX
  500  CONTINUE
  505  CONTINUE
C     COMPUTE REGULAR EQUIVALENCE
  506 DM = DEG(II)+DEG(JJ)
      IF(DM.NE.0.0) B (II,JJ)=CM/DM
c     IF(B (II,JJ).LE.CUT) B (II,JJ)=0.0
      DIFF = B(II,JJ) - B (II,JJ)
      IF(DIFF.LT.0.0) DIFF = -DIFF
      D = D + DIFF
  510  CONTINUE
  520  CONTINUE

      IF((D.LT.0.0.AND.L.NE.1).OR.L.EQ.ITER) IQUIT=1
      n1 = 1
      WRITE(21,901) n1
c symmetrize : to lower half matrix
      DO 650 I = 2, N
      DO 600 J = 1, i-1
      B(i,j) = B(j,i) 
  600 IN(J)=100*B(I,J) + .5
      if (L .eq. 1 .AND. ITER .NE. 1) WRITE(6,901) (IN(J),J=1,i-1)
      IF(IQUIT.NE.1) GO TO 650
      WRITE(5,901) (IN(J),J=1,i-1)
  650 WRITE(21,901) (in(J),J=1,i-1), i
  901 FORMAT(20I4)

      IF(IQUIT.EQ.1) GO TO 800
 
  700 CONTINUE
  800 CONTINUE
      IQUIT=0
 
       IF (IOPTN .NE.1) WRITE (5,77)
77     FORMAT(' REGULAR EQUIVALENCE: Including Transposes')
       IF (IOPTN .EQ.1) WRITE (5,78)
78     FORMAT('STRUCTURAL EQUIVALENCE')
      END