
C
C See if all members of a pedigree are connected
C
      subroutine connect(num,fa,mo,set,nsub,maxgrp)
      integer MAXSIZ,MISS
      parameter(MAXSIZ=1000,MISS=-9999)

      integer maxgrp, nsub
      integer num, fa(MAXSIZ), mo(MAXSIZ)
      integer set(MAXSIZ,2)
C local variables
      integer biggrp,i,idx,numgrp
      logical fin
C
      do 1 i=1,num
        set(i,1)=MISS
        set(i,2)=MISS
    1 continue

      biggrp=1
      idx=1
      maxgrp=0
      numgrp=1
      nsub=1
      set(idx,1)=nsub
      set(idx,2)=idx

      if (num.eq.1) return
C
C while able to update, indicate if individual is part of cluster
C connected to index individual
C
    5 continue
        fin=.true.
        do 10 i=1,num
        if (set(i,1).eq.nsub .and. fa(i).ne.MISS) then
          if (set(fa(i),1).eq.MISS) then
            call addlist(fa(i),idx,set)
            numgrp=numgrp+1
            fin=.false.
          end if
          if (set(mo(i),1).eq.MISS) then
            call addlist(mo(i),idx,set)
            numgrp=numgrp+1
            fin=.false.
          end if
        elseif (set(i,1).eq.MISS) then
          if (fa(i).ne.MISS .and. 
     &        (set(fa(i),1).eq.nsub .or. set(mo(i),1).eq.nsub)) then
            call addlist(i,idx,set)
            numgrp=numgrp+1
            fin=.false.
          end if
        end if
   10   continue
      if (.not.fin) goto 5
C
C Test whether ungrouped individuals remain in pedigree
C If yes, initiate new group around a new index and iterate
C
      if (numgrp.gt.maxgrp) then
        biggrp=nsub
        maxgrp=numgrp
      end if
      do 20 i=1,num
      if (set(i,1).eq.MISS) then
        idx=i
        nsub=nsub+1
        set(idx,1)=nsub
        set(idx,2)=idx
        numgrp=1
        goto 5
      end if
   20 continue
C
C Make biggest subpedigree No. 1
C
      if (biggrp.ne.1) then
        do 25 i=1,num
          if (set(i,1).eq.biggrp) then
            set(i,1)=1
          elseif (set(i,1).eq.1) then
            set(i,1)=biggrp
          end if
   25   continue
      end if
      return
      end
C end-of-connect
C
C shift an individual from the list of ungrouped individuals
C to the appropriate group (subpedigree) nucleating around the index person.
C
      subroutine addlist(pos,idx,set)
      integer MAXSIZ
      parameter (MAXSIZ=1000)
      integer idx,pos
      integer set(MAXSIZ,2)
C
C add the current person to the list after the index person for that family
C
      set(pos,2)=set(idx,2)
      set(pos,1)=set(idx,1)
      set(idx,2)=pos
      return
      end
C end-of-addlist
C
C find list number <target>
C
      subroutine findlist(target,num,set,pos)
      integer MAXSIZ,MISS
      parameter (MAXSIZ=1000,MISS=-9999)
      integer num,pos,target 
      integer set(MAXSIZ,2)
      do 10 pos=1,num
      if (set(pos,1).eq.target) then
        return
      end if
   10 continue
C list not found
      pos=MISS
      return
      end
C end-of-findlist
C
C List the members of pedigree(s)
C
      subroutine wrsubped(pedigree,num,id,key,set,nsub,maxgrp,plevel)
      integer MAXSIZ,MISS
      parameter(MAXSIZ=1000,MISS=-9999)

      integer maxgrp, nsub, plevel
      character*10 pedigree  
      character*8 id(MAXSIZ)
      integer num, key(MAXSIZ)
      integer set(MAXSIZ,2)
C local variables
      integer eop,i
C functions
      integer eow
C
      eop=eow(pedigree)
      write(*,'(/3a,i4,a/7x,a,i4,a/)') 'NOTE:  Pedigree ', 
     2  pedigree(1:eop),' contains ',nsub,' disjoint pedigrees.',
     3  'The largest subpedigree contains ',maxgrp,' members.'
      if (num-maxgrp.lt.20 .and. maxgrp.gt.num/3) then
        do 30 i=1,num
        if (set(i,1).ne.1) then
          write(*,'(/5a)') 
     2   'NOTE:  ',pedigree(1:eop),'-', id(key(i))(1:eow(id(key(i)))),
     3   ' is not a member of the main pedigree.' 
        end if
   30   continue
        write(*,*) 
      end if
      if (plevel.gt.1) then
        write(*,'(/a,i3,a/)') 
     &    'Members of largest subpedigree (N=',maxgrp,')'
        do 40 i=1,num
        if (set(i,1).eq.1) then
          write(*,'(3a)') pedigree(1:eop),'-', id(i)(1:eow(id(i)))  
        end if
   40   continue
        write(*,*)
      end if
      return
      end
C end-of-wrsubped
C
C Work out generation number ord().
C Visit every person in each subpedigree in turn.
C The missing value for generation must be a large negative value.
C
      subroutine gener(pedigree,num,fa,mo,nsub,set,ord,higen,
     &                 nerr,plevel)
      integer MAXSIZ,MISGEN,MISS
      parameter (MAXSIZ=1000,MISGEN=-9999,MISS=-9999)
      integer higen, nerr, plevel
C Pedigree structure
      character*10 pedigree
      integer num, fa(MAXSIZ), mo(MAXSIZ)
      integer ord(MAXSIZ), set(MAXSIZ,2)
C
C
      integer cfa, cgen, cmo, curped, dit, eop, i, idx, it, maxit
      integer logen, upgen
      logical fin, fin2
C functions
      integer eow

      eop=eow(pedigree)
      higen=1
      maxit=2*num
      do 5 i=1,num
        ord(i)=MISGEN
    5 continue
C
C do each subpedigree in turn
C 
      do 10 curped=1,nsub

      call findlist(curped,num,set,idx)
      upgen=0
      logen=0
      ord(idx)=0
      if (plevel.gt.1) then
        write(*,'(a,i5,a,i5)') 'Evaluating sub-pedigree ',curped,
     &    ' via index person ',idx
      end if 

      it=0
      i=idx
C
C Each iteration moves as far down the pedigree as possible then
C moves up no more than one generation
C
   15 continue
        it=it+1
        fin=.true.
C down leg
        dit=0
  100   continue
          fin2=.true.
          dit=dit+1
          if (dit.gt.maxit) then
            write(*,'(/5a/)') 
     2        'ERROR:  Probable illegal loop (eg own grandfather) ',
     3        'in pedigree ', pedigree(1:eop), '.'
            nerr=1
            return
          end if 

  115     continue      
            if (fa(i).ne.MISS) then
              cfa=fa(i)
              cmo=mo(i)
              cgen=max(ord(cfa),ord(cmo))+1
              if ((ord(cfa).ne.MISGEN .or. ord(cmo).ne.MISGEN) .and.
     2            ord(i).ne.cgen) then
                fin2=.false.
                ord(i)=cgen
              end if
            end if
            i=set(i,2)
          if (i.ne.idx) goto 115

        if (.not.fin2) goto 100
C up leg
  215   continue      
          if (fa(i).ne.MISS) then
            cgen=ord(i)
            if (cgen.ne.MISGEN) then
              cfa=fa(i)
              cmo=mo(i)
              if (ord(cfa).eq.MISGEN .or. 
     &            (fa(cfa).eq.MISS .and. cgen.le.ord(cfa))) then
                ord(cfa)=cgen-1
                fin=.false.
              end if
              if (ord(cmo).eq.MISGEN .or.
     &            (fa(cmo).eq.MISS .and. cgen.le.ord(cmo))) then
                ord(cmo)=cgen-1
                fin=.false.
              end if
            end if
          end if
          i=set(i,2)
        if (i.ne.idx) goto 215
C check if finished and update max and min generation number
      if (.not. fin .and. it.le.maxit) goto 15
      if (it.gt.maxit) then 
        write(*,'(/a,i3,a/7x,4a/)') 
     2    'NOTE:  Exceeded ',maxit,' iterations while calculating',
     3    'generation number for pedigree ', pedigree(1:eop), 
     4    ', subpedigree ',curped
      end if
C
C end of main loop
C
C adjust generation numbering to 1..G for founders, marry-ins etc
C
   20 continue     
        if (ord(i).gt.upgen) then
          upgen=ord(i)
        elseif (ord(i).lt.logen) then
          logen=ord(i)
        end if
        i=set(i,2)
      if (i.ne.idx) goto 20
      logen=1-logen
      upgen=upgen+logen
C
   25 continue
        if (fa(i).eq.MISS) then
          ord(i)=ord(i)+logen
        else
          ord(i)=MISGEN
        end if
        i=set(i,2)
      if (i.ne.idx) goto 25
C
C redo nonfounders, now that all founders set correctly
C
      it=0
   30 continue
        it=it+1
        fin=.true.
C
C if both parents have a known generation number, set index to
C max(fa_gen,mo_gen)+1
C
   35   continue
          if (fa(i).ne.MISS) then
            cfa=fa(i)
            cmo=mo(i)
            if (ord(i).eq.MISGEN) then
              if (ord(cfa).ne.MISGEN .and. ord(cmo).ne.MISGEN) 
     &        then
                ord(i)=max(ord(cfa),ord(cmo))+1
              else
                fin=.false.
              end if
            end if
          end if
          i=set(i,2)
        if (i.ne.idx) goto 35

      if (.not.fin) goto 30

      if (upgen.gt.higen) higen=upgen
C
   10 continue
C
      return
      end
C end-of-gener
C
C Write out pedigrees as list of nuclear families plus marry-ins by
C generation number
C
      subroutine dogen(wrk,twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus, numloc,ord,set,trait,plevel)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer plevel, trait, twrk, wrk
C Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer ord(MAXSIZ), set(MAXSIZ,2)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      logical last
      integer biggest,curped,deepest,eop,higen,i,maxgrp,nped,nsub,
     &        onegen,onemem,nerr,nobs,totgen
      character*10 bigped, deeped
C functions
      integer eow
C
      biggest=0
      bigped=' '
      deeped=' '
      deepest=0
      nerr=0
      nobs=0
      nped=0
      onegen=0
      onemem=0
      totgen=0
      if (plevel.lt.1) then
        write(*,'(a)') 'Pedigree    Size Fndrs  Gens Disjoint',
     &                 '---------- ----- ----- ----- --------'
      end if

      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20

        if (actset.gt.0) then
         if (num.gt.1 .or. plevel.gt.1) then
           eop=eow(pedigree)
           call connect(num,fa,mo,set,nsub,maxgrp)
           call gener(pedigree,num,fa,mo,nsub,set,ord,higen,nerr,0)
           if (plevel.gt.0) then
             write(*,'(/a,a10,a,i5,a,i5,a,i2/)') 
     2         'Pedigree ',pedigree,' No=',num,' No founders=',nfound, 
     3         ' No generations=',higen
             if (nsub.gt.1) then
               write(*,'(3x,3a,i4,a/)') 
     2           'Disjoint sub-pedigree ',pedigree(1:eop),
     3           '-001 (largest, N=',maxgrp,')'
             end if
             call wrgen(num,id,fa,mo,1,set,higen,ord)
             if (nsub.gt.1 .and. (nsub.le.10 .or. plevel.gt.0)) then
               do 15 curped=2,nsub
                 write(*,'(/3x,3a,i3.3/)') 
     &             'Disjoint sub-pedigree ',pedigree(1:eop),'-',curped
                 call wrgen(num,id,fa,mo,curped,set,higen,ord)
   15          continue
             end if
           else if (nsub.gt.1) then
             write(*,'(a10,3(1x,i5),3x,a,i4)') 
     &         pedigree, num, nfound, higen, 'y,', nsub
           else
             write(*,'(a10,3(1x,i5))') 
     &         pedigree, num, nfound, higen
           end if
         else
           higen=1
           ord(1)=1
         end if
         if (num.eq.1) onemem=onemem+1
         if (higen.eq.1) onegen=onegen+1
         if (num.gt.biggest) then
           biggest=num
           bigped=pedigree
         end if
         if (higen.gt.deepest) then
           deepest=higen
           deeped=pedigree
         end if
         totgen=totgen+higen
         nped=nped+1
         nobs=nobs+num
C
C save the generation number to a quantitative variable if requested
         if (trait.ne.MISS) then
           do 17 i=1,num
             locus(i,trait)=float(ord(i))
   17      continue
           call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,numloc)
         end if
        end if
      goto 10
   20 continue
      write(*,'(/a,i5/a,i5)') 
     2  'Total number of pedigrees  = ',nped,
     3  'Number with only 1 member  = ',onemem 
      write(*,'(a,i5,3a/a,i5,3a)') 
     4  'Largest pedigree (members) = ',biggest,
     5  ' (Pedigree ',bigped(1:eow(bigped)),')',
     6  'Deepest pedigree (genrtns) = ',deepest,
     7  ' (Pedigree ',deeped(1:eow(deeped)),')' 
      write(*,'(/a,f5.1/a,f5.1)') 
     2  'Mean size of pedigrees     = ',dfloat(nobs)/dfloat(nped),
     3  'Mean pedigree depth        = ',dfloat(totgen)/dfloat(nped) 
      if (nped.gt.onegen) then
        write(*,'(a,f5.1/a,f5.1)') 
     2  'Mean size where >1 members = ',
     3   dfloat(nobs-onegen)/dfloat(nped-onemem),
     4  'Mean depth where >1 members= ',
     5   dfloat(totgen-onegen)/dfloat(nped-onegen)
      end if
      return
      end
C end-of-dogen
C
C Write out structure and generation numbers
C   List of sibships by generation number
C
      subroutine wrgen(num,id,fa,mo,curped,set,higen,ord)
      integer MAXSIZ,MISS
      parameter (MAXSIZ=1000,MISS=-9999)
      integer curped, higen
C Pedigree structure
      integer num
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer ord(MAXSIZ), set(MAXSIZ,2)
C
C assorted counters, indices
C
      integer cfa, cmo, eoi, eoi2, i, j, mat, pos
C Functions
      integer eow

      do 20 j=1,higen
        cfa=MISS
        cmo=MISS
        pos=0
        write(*,'(1x,i3,a,$)') j,': '
        do 25 i=1,num
        if (ord(i).eq.j .and. set(i,1).eq.curped) then
          if (fa(i).ne.MISS) then
            if (fa(i).ne.cfa .or. mo(i).ne.cmo) then
              cfa=fa(i)
              cmo=mo(i)
              eoi=eow(id(cfa))
              eoi2=eow(id(cmo))
              mat=eoi+eoi2+12
              pos=mat
              write(*,'(/7x,5a,$)') 
     &          '{',id(cfa)(1:eoi),' x ',id(cmo)(1:eoi2),'}'
            end if
            eoi=eow(id(i))
            pos=pos+eoi+2
            if (pos.gt.78) then
              pos=mat+eoi+2
              write(*,'(/a,$)') '            '
              do 26 k=13,mat-1
                write(*,'(a1,$)') ' '
   26         continue
              write(*,'(a,$)') '+'
            end if
            write(*,'(2a,$)') '--',id(i)(1:eoi)
          else
            eoi=eow(id(i))
            pos=pos+eoi+3
            if (pos.gt.78) then
              write(*,'(/a,$)') '      '
              pos=eoi+9
            end if
            write(*,'(1x,3a,$)') '(',id(i)(1:eoi),')'
          end if
        end if
   25   continue
        write(*,*)
   20 continue
      return
      end
C end-of-wrgen
C
C Find the ancestor(s) shared by the maximum number of affecteds
C
      subroutine ancest(wrk,locnam,trait,gt,thresh,pedigree,actset,num,
     &                  nfound, id,fa,mo,sex,locus,numloc,aff,plevel)
      integer MAXLOC,MAXSIZ,MISS
      parameter(MAXLOC=120,MAXSIZ=1000,MISS=-9999)

      integer plevel, trait, wrk
      logical gt
      character*10 locnam
      real thresh
      character*10 pedigree  
      character*8 id(MAXSIZ)
      integer actset,num, fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      integer aff(MAXSIZ)
C local variables
      integer bestid, nid, bestfa, nfa, bestmo, nmo, i, totaff
      logical last
C functions
      real isaff
C
      write(*,'(/a/3a/a)')
     2  '--------------------------------------------------',
     3  'Ancestors of probands with trait "',locnam,'"',
     4  '--------------------------------------------------' 
      if (thresh.ne.MISS) then
        if (gt) then
          write(*,'(a,f9.4/)') 
     &      'NOTE:  Proband defined as trait value > ',thresh
        else
          write(*,'(a,f9.4/)') 
     &      'NOTE:  Proband defined as trait value < ',thresh
        end if
      end if
      write(*,'(/a/a)')
     2  'Pedigree   Father   Mother   Number of Affected Descendents',
     3  '---------- -------- -------- ------------------------------'
      last=.false.
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20
C 
C Skip if singleton
C
       if (actset.le.0 .or. num.le.3) goto 10

         totaff=0
         do 25 i=1,num
         if (isaff(locus(i,trait),thresh,gt).eq.2.0) then
           aff(i)=1
           totaff=totaff+1
         else
           aff(i)=0
         end if
   25    continue
C 
C Skip if nobody affected
C
       if (totaff.eq.0) goto 10
C
C Accumulate counts of descendents who are affected
C
         bestid=MISS
         nid=0
         bestfa=MISS
         nfa=0
         bestmo=MISS
         nmo=0
         do 30 i=num,nfound+1,-1
           aff(fa(i))=aff(fa(i))+aff(i)
           aff(mo(i))=aff(mo(i))+aff(i)
   30    continue
C
C Find largest count of affecteds as low in the pedigree as possible
C
         do 40 i=num,nfound+1,-1
           if (aff(i).gt.nid) then
             nid=aff(i)
             bestid=i
           end if
           if ((aff(fa(i))+aff(mo(i))).gt.(nfa+nmo)) then
             bestfa=fa(i)
             nfa=aff(fa(i))
             bestmo=mo(i)
             nmo=aff(mo(i))
           end if
   40    continue
         do 50 i=nfound,1,-1
           if (aff(i).gt.nid) then
             nid=aff(i)
             bestid=i
           end if
   50    continue
C
C Write the best individual ancestor and ancestral mating
C
         call wrdesc(pedigree,id(bestid),sex(bestid),nid,totaff)
         write(*,'(a10,1x,a8,1x,a8,1x,2(i4,a,f5.1,a))') 
     2     pedigree,id(bestfa),id(bestmo),
     3     nfa,' (',float(100*nfa)/float(totaff),'%), ',
     4     nmo,' (',float(100*nmo)/float(totaff),'%)'
         if (plevel.gt.1) then
           write(*,*) 
           do 100 i=1, num
           if (aff(i).gt.1) then
             call wrdesc(pedigree,id(i),sex(i),aff(i),totaff)
           end if
  100      continue
           write(*,*) 
         end if
       goto 10
   20 continue
      return
      end
C end-of-ancest
C write person and number of descendants
      subroutine wrdesc(pedigree,cid,sx,ndesc,ntot)
      character*10 pedigree
      character*8 cid
      integer ndesc, ntot, sx
      if (sx.eq.1) then
        write(*,'(a10,1x,a8,10x,i4,a,f5.1,a)') pedigree,cid,
     &     ndesc,' (',float(100*ndesc)/float(ntot),'%)'
      else
        write(*,'(a10,10x,a8,1x,i4,a,f5.1,a)') pedigree,cid,
     &     ndesc,' (',float(100*ndesc)/float(ntot),'%)'
      end if
      return
      end
C end-of-wrdesc
C
C Prune pedigree to ancestors shared by affecteds
C
      subroutine prunep(wrk,twrk,locnam,trait,gt,thresh,
     2                  pedigree,num,nfound,id,fa,mo,sex,locus,numloc,
     3                  key,ord,set,plevel)
      integer MAXLOC,MAXSIZ,MISS
      parameter(MAXLOC=120,MAXSIZ=1000,MISS=-9999)

      integer plevel, trait, twrk, wrk
      logical gt
      character*10 locnam
      real thresh
      character*10 pedigree  
      character*8 id(MAXSIZ)
      integer actset,num, fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      integer key(MAXSIZ), ord(MAXSIZ), set(MAXSIZ,2)
C local variables
      integer i, no, nf, naff, pos, totno, totnum
      logical last
C functions
      real isaff
C

      totno=0
      totnum=0
      
      write(*,'(/a/3a/a)')
     2  '--------------------------------------------------',
     3  ' Pruning pedigrees of probands with trait "',locnam,'"',
     4  '--------------------------------------------------' 
      if (thresh.ne.MISS) then
        if (gt) then
          write(*,'(a,f9.4/)') 
     &      'NOTE:  Proband defined as trait value > ',thresh
        else
          write(*,'(a,f9.4/)') 
     &      'NOTE:  Proband defined as trait value < ',thresh
        end if
      end if
      if (plevel.gt.1) then
        write(*,'(a/a/)') 
     2    '           Number of        Pedigree Size',
     3    'Pedigree   Index Cases  Original       New'
      end if

      last=.false.
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20
C 
         if (actset.le.0) then
           call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,numloc)
           goto 10
         end if

         totnum=totnum+num
         naff=0
         do 25 i=1,num
           if (isaff(locus(i,trait),thresh,gt).eq.2.0) then
             set(i,1)=1
             set(i,2)=1
             naff=naff+1
           else
             set(i,1)=0
             set(i,2)=0
           end if
           ord(i)=0
   25    continue
C 
C Skip if nobody affected
C
       if (naff.eq.0) goto 10
C
C Accumulate counts of descendents who are affected
C
         do 30 i=num,nfound+1,-1
           set(fa(i),1)=set(fa(i),1)+set(i,1)
           set(mo(i),1)=set(mo(i),1)+set(i,1)
   30    continue
C
C Find MRCAs 
         do 40 i=nfound+1, num
         if (set(i,1).ne.0) then
           if (set(fa(i),1).gt.set(i,1)) set(fa(i),2)=1
           if (set(mo(i),1).gt.set(i,1)) set(mo(i),2)=1
         end if
   40    continue
C Add connectors and other parents, if needed
         do 50 i=nfound+1, num
           if (set(i,1).ne.0) then
             if (set(fa(i),2).ne.0) set(i,2)=1
             if (set(mo(i),2).ne.0) set(i,2)=1
           end if
           if (set(i,2).ne.0) then
             if (set(fa(i),2).ne.0) set(mo(i),2)=1
             if (set(mo(i),2).ne.0) set(fa(i),2)=1
           end if
   50    continue
C
C New founders
         nf=0
         do 60 i=1, nfound
         if (set(i,2).ne.0) then
           nf=nf+1
           ord(i)=nf
         end if
   60    continue
         do 70 i=nfound+1, num
         if (set(i,2).ne.0 .and. 
     &       set(fa(i),2).eq.0 .and. set(mo(i),2).eq.0) then
           nf=nf+1
           ord(i)=nf
           fa(i)=MISS
           mo(i)=MISS
         end if
   70    continue
C New nonfounders
         no=nf
         do 80 i=nfound+1, num
         if (set(i,2).ne.0 .and. ord(i).eq.0) then
           no=no+1
           ord(i)=no
           fa(i)=ord(fa(i))
           mo(i)=ord(mo(i))
         end if
   80    continue
         totno=totno+no
C write new pedigree
         if (plevel.gt.1) then
           write(*,'(a10,1x,i5,2(8x,i5))') pedigree, naff, num, no
         end if
         do 100 i=1,num
         if (ord(i).ne.0) then
           key(ord(i))=i
         end if
  100    continue
         write(twrk) pedigree, actset, no, nf
         do 110 i=1,no
           pos=key(i)
           write(twrk) id(pos),fa(pos),mo(pos),sex(pos),
     &                 (locus(pos,j),j=1,numloc)
  110    continue
       goto 10
   20 continue
      write(*,'(/a,i5,a)') 
     &  'Dropped ',totnum-totno, ' pedigree members.'
      return
      end
C end-of-prunep
