C REGSIM.FOR 3/18/85 - DOUG WHITE'S REGULAR SIMILARITIES PROGRAM C REWRITTEN FOR PC 1/26/2004 drw C This has an additional constraint such that any primary genealogical link (marriage, parent/child, C but not sibling) nullifies the possibility of equivalence. C OUTPUT is writen to file 'COLSNORM'+'Name' DIMENSION IN (377), DEG (377), SUM (377,377), ROW(377), Col(377) COMMON R (377,377,18), B (377,377), N, NR character*12 FILE character*5 names, title 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 Similarities)',16x,'*', +/,12x,54('*'),/,/) c WRITE (*,'(a,\)') ' HOW MANY FILES DO YOU WANT TO STACK? ' c read(*,'(i1)') NR write (*,'(a\)') ' NUMBER OF ITERATIONS? ' read(*,'(i1)') ITER write (*,8992) 8992 format (' CHOOSE AN INITIAL SIMILARITY RELATION ',/, + ' 1. Universal (Regular Similarity)',/, + ' 2. READ A LOWER RECTANGULAR FILE',/, + ' 3. Identity (Structural Similarity)') read (*,'(i1)') INEQ if (ineq.lt.1.or.ineq.gt.3) ineq=1 if (ineq .ne. 2) goto 5 write (*,'(a\)') ' NAME OF FILE? ' read (*,'(A)') FILE C THE FILE IS OPENED OPEN (7, FILE=FILE) 5 IQUIT=0 C N = # NODES NR = # RELATIONS, ITER > 5 NOERRS, CUT C new read data WRITE (*,*)' Name of Data file: ' read (*,'(A)') FILE C THE HEADER FILE IS OPENED OPEN (20, FILE=FILE) Read (20,*) NR ! # relations WRITE (*,*) NR, ' matrices' Read (20,*) N ! # nodes WRITE (*,*) N, ' Nodes' DO KR=1,NR C STACKED RELATION MATRICES ARE READ Read (20,'(A)') Title ! (e.g., year) DO 9 I=1,N 9 READ (20,*) (r(I,J,kr),J=1,N) ENDDO 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') IF (ITER .NE. 1) OPEN (6,FILE='REGGOUT1.DAT') write (*,'(a)') ' 1st ITERATION ON FILE "REGGOUT1.DAT" ' write (*,'(a)') ' Final ITERATION FILE "REGGOUT.DAT" ' C BEGIN ITERATIONS DO 700 L=1,ITER C WRITE(21,160) L 160 FORMAT(10H ITERATION , I3) C INITIALIZE DIFFERENCE IN SUCCESSIVE SE MATRICES D = 0.0 C MOTIF COLORING do i=1,N do j=1,N if (R(I,J,KR).gt.0) B(I,j)=0 enddo enddo 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 C MOTIF COLORING do j=1,N if (R(I,J,KR).gt.0) B(I,j)=0 if (R(J,I,KR).gt.0) B(I,j)=0 enddo 520 CONTINUE IF((D.LT.0.0.AND.L.NE.1).OR.L.EQ.ITER) IQUIT=1 n1 = 1 c 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 continue c WRITE(21,901) (in(J),J=1,i-1), i 901 FORMAT(20I4) C--- IF(IQUIT.EQ.1) GO TO 800 close (6) close (55) file='COLSNORM' file(9:12)=Title(1:4) Open (55,file=file) NumIter=15 C Write (55,*) NumIter DO K = 1, NumIter Xxmax=0.0 C compute row and col totals of B DO I = 1, N B(I,I)=0 DO J = 1, N If (xxmax.lt.B(I,J)) then xxmax=B(I,J) cWrite (*,*) xxmax, B(I,J) c pause endif Row(i)= Row(i)+B(I,j) Col(j)= Col(j)+B(I,j) ENDDO ENDDO C normalize the B matrix and symmetrize DO I = 2, N DO J = 1, i-1 If (row(i).gt.0.and.col(j).gt.0) then B(I,j)=(B(I,j)/Row(i)**.5) /col(j)**.5 B(J,I)=B(I,J) ENDIF ENDDO ENDDO DO I = 1, N ROW(I)=0 COL(I)=0 ENDDO DO I = 1, N DO J = 1, N Row(i)= Row(i)+B(I,j) Col(j)= Col(j)+B(I,j) ENDDO ENDDO If (k.eq.NumIter) then DO I = 1, N WRITE (*,'(2F10.4)') Row(I),Col(i) ENDDO WRITE (*,'(a,i3,a)')' REPEATED NORMALIZATION ', k, ' TIMES' c pause endif ENDDO ! end of normalization DO I = 1, N B(I,I)=xxmax WRITE(55, '(377F8.5)') (10*B(I,J),J=1,N) ENDDO close (55) open (55, file='sim') DO I = 1, N WRITE(55, '(377F8.5)') (10-10*B(I,J),J=1,N) ENDDO IF(IQUIT.EQ.1) GO TO 800 700 CONTINUE 800 CONTINUE IQUIT=0 c IF (IOPTN .NE.1) WRITE (5,77) 77 FORMAT(' REGULAR Similarity Including Transposes') c IF (IOPTN .EQ.1) WRITE (5,78) 78 FORMAT('STRUCTURAL Similarity ') Write (*,'(A,F6.4)') ' max value=', xxmax WRITE (*,*) NR, ' matrices' WRITE (*,*) N, ' Nodes' close (55) open (55, file='lastrun') WRITE(55, '(1x,a)') file WRITE (*,*) ' Output file:', file pause END