C$storage:2 SUBROUTINE CONVERGE (VG,VF,FTREE,GTREE,NMAR,IDIM,IDPTH,L,LL,ID, +ID2,TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, TROLD, FREQ) INTEGER*2 ID(NMAR), TD(NMAR+120), ID2(NMAR), NB (NMAR) INTEGER*2 FC (NMAR,2), GC (NMAR,2), FREQ (11,11) C INTEGER*2 PERCENT (IDIM, 10) INTEGER*2 GTREE(IDIM,IDPTH+1), FTREE(IDIM,IDPTH+1), G1, F1 INTEGER*2 VG ( IDPTH ), VF ( IDPTH ), YEAR (20) INTEGER*2 TROLD (NMAR) CHARACTER*40 G, B C CHARACTER*1 EMPTY CHARACTER*2 SIB IF ( L.LT.1.OR. L.GT.IDIM) RETURN IF (LL.LT.1.OR.LL.GT.IDIM) RETURN ICOUNT=ICOUNT+1 if (mod(icount,100).eq.0) +WRITE (*, '(A,I5)') '+Checking ancestral path', ICOUNT C I9=100 C WRITE(*,'(3X,A,2X,I2,1X,20I1)') EMPTY,L,(VF(I),I=1,L),I9, C +(GTREE(I,L),I=1,NMAR) C CHECK TO SEE THAT THE PATH DOES NOT COME UP THROUGH SAME SEX SIBLING=EGO C DO 20 J=1,NMAR C IF (LL.LE.1.OR.GTREE(J,LL-1).EQ.0) GOTO 20 C IF (L .LE.1.OR.FTREE(J,L -1).EQ.0) GOTO 20 C IF (GTREE(J,LL-1).EQ.FTREE(J,L-1)) FTREE(J,L)=0 C20 CONTINUE C THERE IS STILL A PROBLEM OF CHECKING THAT PATH DOES NOT CONVERGE: C Couple /\___/\ancestor C \/ \/ C DO K=1,40 G(K:K)=' ' ENDDO DO KK=1,LL K=KK IF (VG(KK).EQ.0) G(K:K)='G' IF (VG(KK).EQ.1) G(K:K)='F' ENDDO M=KK G(M:M)='=' DO KK=1,L K=M+KK IF (VF(KK).EQ.0) G(K:K)='G' IF (VF(KK).EQ.1) G(K:K)='F' ENDDO M=2*KLEV+2 DO KK=2,LL K=M+KK-1 IF (VG(KK).EQ.0) G(K:K)='F' IF (VG(KK).EQ.1) G(K:K)='M' ENDDO M=M+LL IF (M.EQ.0) RETURN MHALF=M IF (VF(L).EQ.0) G(M:M)='B' IF (VF(L).EQ.1) G(M:M)='Z' DO KK=1,L-1 K=M-KK+L IF (VF(KK).EQ.0) G(K:K)='S' if (K.le.0) write (*,'(a,5i4)') 'K, M, KK, L', K, M, KK, L IF (VF(KK).EQ.1) G(K:K)='D' ! CHAR EXPR OUT OF RANGE K=0 ENDDO IH=0 IH2=0 IH3=0 IPERIOD=YEAR(20) DO 99 I=1,NMAR IF (IPERIOD.GT.0.AND.IPERIOD.LT.20) THEN IF (GC(I,2).NE.0.AND.(GC(I,2).LT.YEAR(IPERIOD).OR. + GC(I,2).GT.YEAR(IPERIOD)).AND.YEAR(19).NE.1) THEN C -2 => ' ' NOT IN THIS TIME PERIOD ID2 (I)=-2 GOTO 99 ENDIF ENDIF C* DEBUG if (I.gt.idim) WRITE (*, '(A)') ' I > IDIM' DO IG=LL,1,-1 C* DEBUG if (IG.gt.idpth+1) WRITE (*, '(A)') ' IG > IDPTH+1' DO LI= L,1,-1 C* DEBUG if (LI.gt.idpth+1) WRITE (*, '(A)') ' LI > IDPTH+1' CODE ABSENT IF CHAINS MEET BEFORE TOP IF (GTREE(I,IG).EQ.FTREE(I,LI).AND.GTREE(I,IG).GT.0.AND. + FTREE(I,LI).GT.0 .AND.(IG.NE.LL.OR.LI.NE.L)) THEN C 8 => '-' ID2 (I)=8 IH3 = IH3 + 1 GOTO 99 ENDIF ENDDO ENDDO C DEFAULT - NO DEFINITE CONCLUSION C -3 => '?' ID2 (I) = -3 DO IG=LL-2,1,-1 CODE MISSING IF NO DATA IF (GTREE(I,IG).EQ.0) GOTO 99 ENDDO DO LI=L-2,1,-1 CODE MISSING IF NO DATA IF (FTREE(I,LI).EQ.0) GOTO 99 ENDDO G2=GTREE(I,LL) F2=FTREE(I, L) IF (LL.LE.1) THEN G1=I ELSE G1=GTREE(I,LL-1) ENDIF IF ( L.LE.1) THEN F1=I ELSE F1=FTREE(I, L-1) ENDIF IF ((G2.EQ.0.AND.F2.EQ.0).OR.F1.EQ.0.OR.G1.EQ.0) THEN C DEFINITELY NO INFORMATION C -1 => '.' ID2 (I)=-1 GOTO 99 ENDIF C THERE EXISTS A MATCH: IF (G2.EQ.F2.AND.G2*F2.GT.0) THEN COUNTER FOR SUFFICIENT DATA IH3=IH3+1 C 1 => '1' ID2 (I)= 1 IH=IH+1 FREQ (LL,L)= FREQ (LL,L)+1 ID(IH) = I TROLD(IH)=I C TD LINKS - IN REDUCED NETWORK - ARE MADE ONLY WHEN THERE IS A MATCH C* ADD MATCHED COUPLE TD (I)=1 C* ADD ANCESTORS UP MALE SIDE DO KK=1,LL IF (GTREE(I,KK).NE.0) TD (GTREE(I,KK))=1 ENDDO C* ADD ANCESTORS UP FEMALE SIDE DO KK=1,L IF (FTREE(I,KK).NE.0) TD (FTREE(I,KK))=1 ENDDO if ( I .EQ.ITEST) then WRITE (*,'(I4,A,20I5)') I, ' VG ',(VG(J),J=1,LL) WRITE (*,'(I4,A,20I5)') I, ' GTREE',(GTREE( I ,J),J=1,LL) WRITE (*,'(I4,A,20I5)') I, ' GC 1 ',(GC(GTREE(I,J),1),J=1,LL) WRITE (*,'(I4,A,20I5)') I, ' VF ',(VF(J),J=1,L) WRITE (*,'(I4,A,20I5)') I, ' FTREE',(FTREE( I ,J),J=1,L) WRITE (*,'(I4,A,20I5)') I, ' FC 1 ',(FC(GTREE(I,J),1),J=1,LL) PAUSE endif GOTO 99 ENDIF C INCOMPLETE DATA BUT ... THERE IS AN EXTRA NEGATIVE INFERENCE TO BE MADE ... IF ((G2.EQ.0.OR.F2.EQ.0).AND.(G2.NE.0.OR.F2.NE.0).AND. + G1.NE.0.AND.F1.NE.0) THEN C IF I KNOW THE PARENTS OF ONE AND ALL BUT THE PARENTS OF THE OTHER ... THEN C I CAN INFER THAT AT ONE LESS THAN THE TOP GENERATION THESE ARE NOT SIBLINGS COUNTER FOR SUFFICIENT DATA IH2=IH2+1 C 9 => 'a' ID2 (I)=9 GOTO 99 ENDIF IF (G2.NE.F2) THEN C SUFFICIENT DATA BUT NOT A COMMON ANCESTOR COUNTER FOR SUFFICIENT DATA IH3=IH3+1 C 0 => '0' ID2 (I)=0 GOTO 99 ENDIF write (*, '(A,I4)') ' Problem with case ', I pause 99 CONTINUE IH3=IH2+IH3 IP=0 IF (IH3.GT.0) IP=INT(100*IH/IH3) CDRWNEW IF (IH.GT.0) THEN C WRITE (4, '(1X,A,I4,I5,A,i5,9000i4)') G, IH, IP,'%', C + (TROLD (I),I=1,IH), (ID2 (I),I=1,NMAR) B=G IHH=0 IHOLD=0 SIB=G(MHALF-1:MHALF) C _Z => FZ (male ego) IF (SIB(1:2).EQ.' Z') SIB (1:1)='F' C _B => FB (male ego) IF (SIB(1:2).EQ.' B') SIB (1:1)='F' DO 190 I=1,IH IF (SIB.EQ.'MB'.OR.SIB.EQ.'FZ') GOTO 188 C ID(I) because 1,IH is reduced IF (LL.LE.1) THEN G1=ID(I) ELSE G1=GTREE(ID(I),LL-1) ENDIF IF ( L.LE.1) THEN F1=ID(I) ELSE F1=FTREE(ID(I), L-1) ENDIF C* debug keep this in comments C if (NB(ID(i)).eq.7.or.NB(ID(i)).eq.11) then C write (*, '(1x,3a,6i4)') G,SIB,' LL= ',LL, ID(i), C + F1,GC(F1,1),G1,GC(G1,1) C endif C ONE DEEP LL=1 or L=1 IF (SIB(2:2).EQ.'B'.AND.LL.EQ.1) GOTO 187 C EXCLUDE BECAUSE male's Z CROSSOVER C IF (SIB(2:2).EQ.'Z'.AND. L.EQ.1) GOTO 187 IF (SIB.EQ.'MZ'.AND.(FC(F1,1) + FC(G1,1).EQ.0.OR. + FC(F1,1).NE.FC(G1,1))) GOTO 188 C IF ( IF (SIB.EQ.'FB'.AND.(GC(F1,1) + GC(G1,1).EQ.0.OR. + GC(F1,1).NE.GC(G1,1))) GOTO 188 ! Fathers not same C want this to be true for Nahor marrying Haran's da (NE) C not true for Lot and daughter because of goto 187 above ("B" and LL=1) C (F)BD vs (F)^D --> if both types write full vector, then write C + NO YES C WHAT HAPPENS IF BD? C WRITE (*,'(/40x,A,4I4)')' F1/GC G1/GC',F1,GC(F1,1),G1,GC(G1,1) C B/Z -> ^ 187 G(MHALF:MHALF)='^' C if (LL.EQ.1.and.GC(F,1).eq.GC(G1,1)) C STORE OLD IH 1 to J, NEW IHH from end to J+1 C IDI = TROLD (IH-IHH) IDI = TROLD (I -IHH) C TROLD (IH-IHH) = TROLD (I) TROLD (I-IHH) = TROLD (I) TROLD (I) = IDI IHH=IHH+1 IHOLD=IHOLD-1 GOTO 189 188 TROLD (IHOLD+1)=TROLD (I) 189 IHOLD=IHOLD+1 190 CONTINUE C* jtest, ktest IH=IHOLD IYEAR20=YEAR(19)-YEAR(20) CDRWNEW IF (IH.EQ.0) WRITE(4,'(1X,A,I1,I4,A,2i4,A,i5,9000i4)')B,IYEAR20, + IH, '/',IH3 IF (IH.GT.0) WRITE(4,'(1X,A,I1,I4,A,2i4,A,i5,9000i4)')B,IYEAR20, + IH, '/',IH3,IP,'%',(TROLD(I),I=1,IH), (ID2(I),I=1,NMAR) IF (IHH.GT.0)WRITE(4,'(1X,A,I1,I4,A,2i4,A,i5,9000i4)')G,IYEAR20, + IHH,'/',IH3,IP,'%',(TROLD(I),I=IH+IHH,IH+1,-1),(ID2(I),I=1,NMAR) C PERCENTS (NMAR, 10) - for each couple, classify LOWEST L at level LL C PROBLEM WHEN THERE ARE MORE THAN ONE CONVERGENT LINK ? C DO I=1,IH CC IF (LL.LE.10) PERCENT (TROLD(I), LL)=L C IF (LL.LE.10.AND.L.LE.10) CC IPC=PERCENT (TROLD(I), LL) CC IF (LL.LE.10.AND.IPC.EQ.0) PERCENT (TROLD(I), LL)=L CC IF (LL.LE.10.AND.IPC.NE.0.AND.L.LT.IPC) PERCENT (TROLD(I), LL)=L C ENDDO C DO I=1,IHH CC IF (LL.LE.10) PERCENT (TROLD(I), LL)=L C IF (LL.LE.10.AND.L.LE.10) FREQ (LL,L)= FREQ (LL,L)+1 CC IPC=PERCENT (TROLD(I), LL) CC IF (LL.LE.10.AND.IPC.EQ.0) PERCENT (TROLD(I), LL)=L CC IF (LL.LE.10.AND.IPC.NE.0.AND.L.LT.IPC) PERCENT (TROLD(I), LL)=L C ENDDO CDRWNEW ENDIF C* debug C do i=1,IHH C if (ID(i).eq.7.and.LL.eq.2.and.L.eq.3) then C stop C endif C enddo C do i=1,IH C if (ID(i).eq.7.and.LL.eq.2.and.L.eq.3) then C stop C endif C enddo C IF (IH.GT.0) THEN C WRITE (4, '(A,A,I4,I5,A,i5,9000i4)') '&', G, IH,IP,'%',(TROLD(I),I=1,IH) C WRITE (4, '(A,2050I4)') '&', (ID2 (I),I=1,NMAR) C WRITE (4, '(A)') '2' C ENDIF END