$nofloatcalls
$LARGE R
$storage:2
C REGDI.FOR 3/18/85 - DOUG WHITE'S REGULAR DISTANCES PROGRAM
C
C  THE ITERATIONS ARE WRITTEN ON USER SPECIFIED OUTPUT FILE
      DIMENSION  IN (82), DEG (82), SUM (82,82)
      COMMON R (82,82,18), B (82,82), 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,'*',20x,'R E G D I S',21x,'*',/,
     +12x,'*',17x,'(Regular Distances)',16x,'*',
     +/,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 DISTANCE RELATION ',/,
     + ' 1. <default> Universal (Regular Distance)',/,
     + ' 2. READ A LOWER RECTANGULAR FILE',/,
     + ' 3. Identity (Structural Distance)')
      read (*,'(i1)') INEQ
      if (ineq .ne. 2) goto 5
      write (*,'(a\)') ' NAME OF DISTANCE FILE? '
      read (*,'(A)') FILE
C THE DISTANCE 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 DISTANCE
      DO 100 I=1,N
      DEG(I)=0.0
      DO 100 J=1,N
      SUM(I,J)=0.0
      DO 50 KR=1,NR
      SM = R(I,J,KR)**2 + R(J,I,KR)**2
   50 SUM(I,J)=SUM(I,J) + sm
  100 DEG(I)=DEG(I)+SUM(I,J)

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

      OPEN (5,FILE='REGDOUT.DAT',STATUS='new')
      IF (ITER .NE. 1) OPEN (6,FILE='REGDOUT1.DAT',STATUS='new')
      write (*,'(a)') ' OUTPUT FILE IS "REGDOUT.DAT" '
      write (*,'(a)') ' ITERATION 1 IS "REGDOUT1.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)
C                   J-->K, K-->J IN SECOND ITERATION
 120  DO 500 K=1,N
      IF(SUM(I,K).EQ.0.0) GO TO 500
      XMIN=10000000000.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 + (R(I,K,KR) - R(J,M,KR)) **2 
     *            + (R(K,i,KR) - R(M,j,KR)) **2 
      CMIKJM = max (Summ, sum(i,k) * 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=DEG(II)+DEG(JJ)
      IF(CMIKJM.LT.XMIN) XMIN= CMIKJM
 
      IF(XMIN.EQ.0) GO TO 450
 
  400 CONTINUE
C     ADD BEST MATCHES TO REGULAR DISTANCE NUMERATOR FOR I,J
  450 CM=CM+XMIN
  500  CONTINUE
  505  CONTINUE
C     COMPUTE REGULAR DISTANCE
  506 DM = DEG(II)+DEG(JJ)
C REMEMBER BOTH POINTS TAKEN AS REFERENCE
      if(cm.gt.dm) cm=DM
      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)
      close (6)

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