C$Storage:2
      SUBROUTINE GRAPH (G,F,IDIM,NMAR,ID,TD,TROLD,NEWNUM,NB)
      INTEGER*2 G(NMAR),F(NMAR),ID(NMAR), TD(NMAR+120), TROLD(NMAR),
     + NB(IDIM)
C
C     Renumber all marriages if TD(I)=1
C
      NEWNUM=0
      DO I=1,NMAR
      IF (TD(I).EQ.1) THEN
        NEWNUM=NEWNUM+1
C       NEWNO(I)=NEWNUM
        TROLD(NEWNUM)=I
      ENDIF
      ENDDO
           
      if (nmar.le.100) then
      DO 50 K=1,2
      IF (K.EQ.1) THEN
        NUM=NEWNUM
        WRITE (6, '(I4,2A)') Num," '",'Couples in Reduced Graph'
C
C     Build Reduced Graph Row by Row
C
      ELSE
        NUM=NMAR
        WRITE (6, '(I4,2A)') Num," '",' Couples in Marriage Graph'
C
C     Build Marriage Graph Row by Row
C
      ENDIF
      DO 40 I=1,NUM
                   
      DO J=1,NUM
      ID(J)=0
      ENDDO
           
      DO J=1,NUM
      IF (K.EQ.1) THEN
        IF (G(TROLD(J)).EQ.TROLD(I)) ID(J)=1
        IF (F(TROLD(J)).EQ.TROLD(I)) ID(J)=2
      ELSE
        IF (G(J).EQ.I) ID(J)=1
        IF (F(J).EQ.I) ID(J)=2
      ENDIF
      ENDDO
           
      IF (K.EQ.1) WRITE (6, '(2I4,1X,9000I1)') TROLD(I), NB(TROLD(I)),
     +(ID(J),J=1,NUM)
      IF (K.EQ.2) WRITE (6, '(2I4,1X,9000I1)') I, NB(I),(ID(J),J=1,NUM)
 40   CONTINUE
 50   CONTINUE
      ENDIF
C MARRIAGE CIRCLES ROUTINE
      END
         
         
      SUBROUTINE NEXT (EMPTY,IDIM,IDPTH,X,XTREE,L,NMAR)
C
C   Take X(existing XTREE (L-1))
C   Store new vector for pattern V in XTREE (L)
C
      INTEGER*2 X(NMAR), XTREE(IDIM,IDPTH+1)
      CHARACTER*1 EMPTY
      EMPTY='N'
      IF (L.LE.1.OR.L.GT.IDIM) RETURN
      EMPTY='Y'
      DO I=1,NMAR
      XTREE(I,L)=0
      IF (XTREE(I,L-1).GT.0) XTREE(I,L)=X(XTREE(I,L-1))
      IF (XTREE(I,L).GT.0) EMPTY='N'
      ENDDO
      END
         
      SUBROUTINE FEMALE(VG,VF,G,F,GTREE,FTREE,IDIM,IDPTH,NMAR,LL,ID,ID2,
     +TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, CARE,TROLD,FRQ,FRP,
     +NUMF,LENF,GD, GF)
C NOTE: LL is MALE INDEX, L WILL BE FEMALE INDEX
      INTEGER*2 G(NMAR),F(NMAR),ID(NMAR), TD(NMAR+120), ID2(NMAR)
      INTEGER*2 NB (NMAR), FC (NMAR,2), GC (NMAR,2), FRQ (11,11)
      INTEGER*2 FRP (11,11)
      INTEGER*2 GTREE(IDIM,IDPTH+1), FTREE(IDIM,IDPTH+1), TROLD (NMAR)
      INTEGER*2 VG ( IDPTH ), VF (IDPTH), YEAR (20), GD (NMAR), GF(NMAR)
      CHARACTER*1 EMPTY, CARE
                             
      IF (LL.LT.1.OR.LL.GT.IDIM) RETURN
C      I9=100
      L=1
      VF(L)=1
C use     F=1 subroutines below
C     IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,F,FTREE,L,NMAR, CARE,MN)
      IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,F,FTREE,L,NMAR, CARE,NB)
C* DEBUG
c     KEEPSEP=888888
c     WRITE (*,'(A,20I4)') ' VG,VF ',(VG(J),J=1,LL), KEEPSEP,
c    + (VF(J),J=1,L)
                    
      IF (LL.EQ.1) CALL LINKGG (L, FTREE, NMAR, IDIM, IDPTH, VF, 2,
     +NUMF, LENF, GD, GF)
      CALL CONVERGE (VG, VF, FTREE,GTREE,NMAR,IDIM,IDPTH,L,LL,ID,
     +ID2,TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, TROLD, FRQ)
                                                              
 30   L=L+1
      IF (L.GT.KLEV) THEN
        L=L-1
        GOTO 40
      ENDIF
      VF(L)=0
C use     G=0 in subroutines below
        CALL NEXT (EMPTY,IDIM,IDPTH,G,FTREE,L,NMAR)
C       IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,G,FTREE,L,NMAR,CARE,MN)
        IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,G,FTREE,L,NMAR,CARE,NB)
C       IF EMPTY THEN BACKTRACK TO 40; IF NOT EMPTY THEN FORWARD TO 30
        IF (EMPTY.EQ.'Y') GOTO 40
      IF (LL.EQ.1) CALL LINKGG (L, FTREE, NMAR, IDIM, IDPTH, VF, 2,
     +NUMF, LENF, GD, GF)
      CALL CONVERGE (VG, VF, FTREE,GTREE,NMAR,IDIM,IDPTH,L,LL,ID,
     +ID2,TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, TROLD, FRQ)
           GOTO 30
C          FORETRACK
C     BACKTRACK ROUTINE
 40   CONTINUE
      IF (VF(L).EQ.1) THEN
         L=L-1
         IF (L.LE.1) GOTO 50
         GOTO 40
      ENDIF
      VF(L)=1
C use     F=1 subroutines below
        IF (L.LE.1) GOTO 50
C          FORETRACK
        CALL NEXT (EMPTY,IDIM,IDPTH,F,FTREE,L,NMAR)
C       IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,F,FTREE,L,NMAR,CARE,MN)
        IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,F,FTREE,L,NMAR,CARE,NB)
        IF (EMPTY.EQ.'Y') THEN
           L=L-1
           IF (L.LE.1) GOTO 50
           GOTO 40
C          BACKTRACK
        ELSE
C     NONEMPTY SO TEST
      IF (LL.EQ.1) CALL LINKGG (L, FTREE, NMAR, IDIM, IDPTH, VF, 2,
     +NUMF, LENF, GD, GF)
      CALL CONVERGE (VG, VF, FTREE,GTREE,NMAR,IDIM,IDPTH,L,LL,ID,
     +ID2,TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, TROLD, FRQ)
           GOTO 30
C          FORETRACK
        ENDIF
C END TREE
  50   CONTINUE
               
C     I9=100
C     WRITE(*,'(1X,A,2X,I2,1X,20I1)') EMPTY,LL,(VG(I),I=1,LL),I9,
C    +(GTREE(I,LL),I=1,NMAR)
      END
         
      SUBROUTINE LINKGG (L, XTREE, NMAR, IDIM, IDPTH, VG, IDEV,
     +NUMG, LENG, GD, GF)
      INTEGER*2 XTREE(IDIM,IDPTH+1), GD(idim), GF(idim), VG (IDPTH)
      INTEGER*4 IDEV
      CHARACTER*10 GC
      INDEX=0
      DO I=1,L
      IF (VG(I).EQ.0) THEN
        GC(I:I)='G'
      ELSE
        GC(I:I)='F'
      ENDIF
      ENDDO
      DO I=1,NMAR
        IF (XTREE(I,L).GT.0) THEN
        INDEX=INDEX+1
        GD(INDEX)=I
        GF(INDEX)=XTREE(I,L)
        ENDIF
      ENDDO
      NUMG=NUMG+1
      IF (INDEX.GT.LENG) LENG=INDEX
      WRITE (idev, '(I2,A,A,I4,A,60000I4)') L, ':',GC(1:L),INDEX,':',
     +(GD(I),I=1,INDEX),(GF(I),I=1,INDEX)
C4
C1:G  6:   4   7   9  11  13 181  37 101  13   4   1   0
C2:GG  0:
C2:GF  0:
C3:GGG  0:
      END
         
      SUBROUTINE  READONLY (FILENAME, ISW, IDEV)
      CHARACTER*14 FILENAME, FILEE
      INTEGER*4 IDEV
      IF (ISW.EQ.1) GOTO 547
      OPEN (IDEV, file=filename, status='unknown')
      WRITE (IDEV,*, err=547) ' test'
      close (IDEV)
      OPEN (IDEV, file=filename, status='unknown')
      RETURN
547   filee(3:14)=filename(1:12)
      filee(1:2)='a:'
      OPEN (IDEV, file=filee, status='unknown')
      ISW=1
      END
         
      subroutine core (F, G, NMAR)
      integer*2 F(NMAR), G(NMAR)
      do kk=1,100
      ichange=0
      do i=1,NMAR
CFEMALE PARENTS f() only
      IF (F(I).GT.0) THEN
        if (F(I).gt.nmar) then
          write (*,'(3(I4,A))') I, 'TH F ELEMENT IS ', F(I), ' > NMAR'
        endif
        IF (F(F(I)).LE.0.AND.G(F(I)).LE.0) THEN
CGZ upper terminus
          do j=1,NMAR
          if (I.NE.J.AND.(F(J).EQ.F(I).OR.G(J).EQ.F(I))) GOTO 675
          enddo
C* no sibling branch
          if (F(I).NE.0) ichange=1
          F(I)=0
675       CONTINUE
        ENDIF
      ENDIF
      IF (F(I).GT.0.AND.G(I).LE.0) THEN
          do j=1,NMAR
          if (F(J).EQ.I.OR.G(J).EQ.I) GOTO 676
          enddo
Clower terminus: spouse's parents unknown
          if (F(I).NE.0) ichange=1
          F(I)=0
676     CONTINUE
      ENDIF
CMALE PARENTS g() only
      IF (G(I).GT.0) THEN
        if (G(I).gt.nmar) then
          write (*,'(3(I4,A))') I, 'TH G ELEMENT IS ', G(I), ' > NMAR'
        endif
        if (F(G(I)).LE.0.AND.G(G(I)).LE.0) THEN
Cupper terminus
          do j=1,NMAR
          if (I.NE.J.AND.(F(J).EQ.G(I).OR.G(J).EQ.G(I))) GOTO 677
          enddo
C* no sibling branch
          if (G(I).NE.0) ichange=1
          G(I)=0
677       CONTINUE
        ENDIF
      ENDIF
      IF (G(I).GT.0.AND.F(I).LE.0) THEN
          do j=1,NMAR
          if (F(J).EQ.I.OR.G(J).EQ.I) GOTO 679
          enddo
Clower terminus: spouse's parents unknown
          if (G(I).NE.0) ichange=1
          G(I)=0
679     CONTINUE
      ENDIF
      enddo
      if (ichange.eq.0) RETURN
      enddo
      END
         
      SUBROUTINE PAR_CULL (F, G, ID, YES, BK, FC, GC, ext, nmar, anss)
      INTEGER*2     F(nmar), G(nmar), ID(nmar), YES(nmar)
      INTEGER*2     BK(nmar*2), FC(nmar), GC(nmar)
      CHARACTER*1 YN, YS
      CHARACTER*3 EXT, ANSS
      CHARACTER*14 FILENAME
      CHARACTER*40 TITLE
      LOGICAL EX
C     write (*, '(A\)') ' Three letter extension of .VEC file: '
C     read (*, '(A\)') ext
      filename='P-XXX.VEC'
      filename(9:9)=ANSS
      filename (3:5)=ext
C     write (*, '(1x,A)') filename
      open (1, file=filename)
      read (1, '(I4, A)') N, TITLE
C     write (*, '(A,I4)') ' N= ', N
C     write (*, '(A,I4)') ' NMAR= ', NMAR
      read (1, *) (G(I),I=1,N)
      read (1, *) (F(I),I=1,N)
      read (1, *,END=87,ERR=87) (GC(I),I=1,N)
      read (1, *,END=87,ERR=87) (FC(I),I=1,N)
 1    read (1, *,END= 2,ERR= 2) (ID(I),I=1,N)
      do i=1,n
      if (ID(I).eq.0) goto 1
      enddo
      CLOSE (1)
 5    CONTINUE
      YN='I'
C     write (*, '(A\)') ' Index (I) or Label (L) numbers? '
C     read (*, '(A\)') YN
      If (YN.eq.'i') YN='I'
      If (YN.eq.'l') YN='L'
      If (YN.NE.'L'.AND.YN.NE.'I') GOTO 5
      GOTO 3
 87   DO I=1,N
      GC(I)=0
      FC(I)=0
      ENDDO
 2    DO I=1,N
      ID(I)=I
      ENDDO
      YN='I'
 3    CONTINUE
C******AUTOMATED READ YES
      filename (7:9)="LST"
      inquire (file=filename, EXIST=EX)
      IF (EX) THEN
C       write (*,'(3a\)') ' enter by hand (Y) or read <Rtn> from ',
C    +   filename,"?"
C       read (*,'(A)') ys
        if (ys.eq.'y') ys='Y'
        if (ys.eq.'Y') goto 15
        if (ys.eq.'Y') goto 9
        OPEN (1, file=filename)
        DO I=1,N
          YES(I)=0
        ENDDO
        DO I=1,N
          Read (1,*, end=11,err=11) IN, IN2
          if (yn.eq.'L') IN=  IN2
C         Write(*,*) IN
          YES(IN)=1
        ENDDO
      ENDIF
      GOTO 15
             
C******READ YES BY HAND
      write (*,'(2a)') ' no ', filename
 9    DO I=1,N
      YES(I)=0
      ENDDO
      DO I=1,N                   ! TEST WHETHER NUMBERS REPEAT
        IF (ID(I).EQ.0) goto 4
        IF (YES(ID(I)).EQ.1) goto 1
            YES(ID(I))=1
 4    ENDDO
C======
15    DO I=1,N
C       YES(I)=0
        BK(I)=0
      ENDDO
      DO I=1,N
          IF (ID(I).GT.0) BK(ID(I))=I
      ENDDO
      DO I=1,N
C       write (*, '(A\)') ' Next Couple to Include (0 to end): '
C       read (*, '(I4)') K
        K=0
        IF (K.LE.0) GOTO 11
        IF (YN.EQ.'L') THEN
          IF (BK(K).GT.0) THEN
            YES(BK(K))=1
          ELSE
            WRITE (*,*) ' No Couple with this ID Number '
          ENDIF
        ELSE
          IF (K.LE.N) THEN
            YES(K)=1
          ELSE
            WRITE (*,*) ' Couple Number too large '
          ENDIF
        ENDIF
      ENDDO
 11   CLOSE (1)
 10   MORE=0
            
C******BEGIN ANALYIS
      DO I=1,N
      IF (YES(I).EQ.1) THEN
        IF (G(I).GT.0) THEN
          IF (YES(G(I)).EQ.0) MORE=1
              YES(G(I))   =1
        ENDIF
        IF (F(I).GT.0) THEN
          IF (YES(F(I)).EQ.0) MORE=1
              YES(F(I))   =1
        ENDIF
      ENDIF
      ENDDO
      IF (MORE.EQ.1) GOTO 10
      DO I=1,N
      BK(I)=YES(I)
      IF (YES(I).EQ.0) THEN
      ID(I)=0
      G(I)=0
      F(I)=0
      ENDIF
      YES(I)=0
      ENDDO
      filename='P-XXX.VEB'
C     filename (3:5)='xxx'
      NN=0
      DO i=1,N
      IF (BK(i).eq.1) THEN
       NN=NN+1
       YES(I)=NN
      ENDIF
      ENDDO
           
      open (1, file=filename)
 20   continue
C     write (*, '(A\)')
C    +' Original or Condensed format for p-xxx.vec to save? 2<Rtns> '
C     read (*, '(A)') YN
      YN='O'
      if (YN.eq.'C'.or.YN.eq.'c') THEN
CNOT USED !
        write (*,*) ' Condensed'
        write (1, '(I4,1x,A)') NN, TITLE
        DO i=1,N
        IF (BK(i).eq.1.AND.G(I).GT.0) write (1, '(I5)') YES(G(I))
        IF (BK(i).eq.1.AND.G(I).EQ.0) write (1, '(I5)') G(I)
        ENDDO
        DO i=1,N
        IF (BK(i).eq.1.AND.F(I).GT.0) write (1, '(I5)') YES(F(I))
        IF (BK(i).eq.1.AND.F(I).EQ.0) write (1, '(I5)') F(I)
        ENDDO
        DO i=1,N
        IF (BK(i).eq.1) write (1, '(I5)') ID(I)
        ENDDO
      ELSE
        if (YN.ne.'O'.and.YN.ne.'o') goto 20
C       write (*,*) ' Original'
        write (1, '(I4,1x,A)') N, TITLE
        if (n.lt.1000) then
        write (1, '(I3,19I4)') (G(I),i=1,n)
        write (1, '(I3,19I4)') (F(I),i=1,n)
        write (1, '(I3,19I4)') (GC(I),I=1,N)
        write (1, '(I3,19I4)') (FC(I),I=1,N)
        write (1, '(I3,19I4)') (ID(I),i=1,n)
        else
        write (1, '(15I5)') (G(I),i=1,n)
        write (1, '(15I5)') (F(I),i=1,n)
        write (1, '(15I5)') (GC(I),I=1,N)
        write (1, '(15I5)') (FC(I),I=1,N)
        write (1, '(15I5)') (ID(I),i=1,n)
        endif
      ENDIF
      close (1)
      open (1, file='p-xxx-p.crd')
      close (1, status='delete')
      open (1, file='p-xxx-m.crd')
      close (1, status='delete')
      open (1, file='p-xxx-o.crd')
      close (1, status='delete')
      open (1, file='p-xxx.lst')
      DO I=1,N
      IF (G(I).GT.0.OR.F(I).GT.0) WRITE (1,*) I, ID(I)
      ENDDO
      end
         
c     IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,F,FTREE,L,NMAR,CARE,MN)
c     IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,G,FTREE,L,NMAR,CARE,MN)
c     IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,F,FTREE,L,NMAR,CARE,MN)
      SUBROUTINE CHECK (IDIM,IDPTH,X,XTREE,L,NMAR, CARE, MN)
      INTEGER*2 X(NMAR), XTREE(IDIM,IDPTH+1), MN(NMAR)
      CHARACTER*1 CARE
      IF (L.LE.1.OR.L.GT.IDPTH) RETURN
      DO I=1,NMAR
C CHECK TO SEE THAT SOMEONE IS NOT THEIR OWN ANCESTOR
      IF (XTREE(I,L).EQ.I) THEN
       WRITE (*, '(A,I5,A/30I5)') ' Couple:', I, ' in cycle of couples w
     +ho are their own ancestors:', I, (XTREE(I,J),J=1,L)
       WRITE (*, '(A,I5,A/30I5)') ' Labels:',MN(I), ' in cycle of couple
     +s who are their own ancestor:', MN(I), (MN(XTREE(I,J)),J=1,L)
       WRITE (*, '(A\)') ' Do you care? '
       READ (*,  '(A)') CARE
       IF (CARE.EQ.'y') CARE='Y'
       XTREE(I,L)=0
       X(I)=0
      ENDIF
      ENDDO
      END