C
C check for simple inconsistencies between child and parent
C if requested, delete any problem genotypes (up to and including
C all genotypes for a nuclear family)
C
C error                                     action if droperr
C ----------------------------------------  ----------------------------
C 11=single parent-offspring inconsistency  delete child genotype
C 12=Multiple p-o inconsistencies           delete all nuclear fam genos
C 13=Inconsistencies between siblings       delete all nuclear fam genos
C 14=More than 4 alleles segregating        delete all nuclear fam genos
C
C
      subroutine check(pedigree,num,nfound,id,fa,mo,sex,locus,
     2                 nloci,loc,loctyp,locpos,set,xmale,
     3                 droperr,ndiscard,inconsist,plevel)
      integer KNOWN,MAXLOC,MAXSIZ,MISS
      parameter (KNOWN=0,MAXLOC=120,MAXSIZ=1000,MISS=-9999)
      integer droperr, inconsist, ndiscard, plevel
C Pedigree structure
      character*10 pedigree
      integer num,nfound 
      character*8 id(MAXSIZ) 
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C
      integer nloci
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)
C
C count of segregating alleles
      integer nall, allele(5)
C sibship genotypes
      integer set(MAXSIZ,2)
      logical xmale(MAXSIZ)
C other local variables
      integer c1,c2,currf,currm,eop,gene,gen2,i,j,
     &        nkids, p11,p12,p21,p22,sta
      integer bad1, bad2, badchild, errtyp
      integer ptyped
      logical err, thiserr, xlinkd
      character*7 gtp
C functions
      integer eow, parcon
      logical opcon
C
      eop=eow(pedigree)
      do 10 j=1,nloci
      if (loctyp(j).le.2) then 
        xlinkd=(loctyp(j).eq.2)
        badchild=MISS
        gene=locpos(j)
        gen2=gene+1
        nkids=0
        ptyped=0
        currf=MISS
        currm=MISS
C
C Check for male X-linked heterozygotes
        if (xlinkd) then
          err=.false.
          do 15 i=1, num
          if (sex(i).eq.1 .and. locus(i,gene).gt.KNOWN .and.
     &        locus(i,gene).ne.locus(i, gen2)) then
            call wrgtp(int(locus(i,gene)), int(locus(i,gen2)),gtp,1)
            write(*,'(/9a/)') 'ERROR: Heterozygous male ',
     2        pedigree(1:eop),'-',id(i)(1:eow(id(i))),
     3        ' at X-linked locus ',loc(j),' {',gtp,'}'
            if (droperr.gt.0) then
              locus(i,gene)=MISS
              locus(i,gen2)=MISS
            else
              err=.true.
              inconsist=inconsist+1
            end if
          end if
   15     continue
          if (err) return
        end if
C
C Check each nuclear family
C
        err=.false.
        do 20 i=nfound+1,num
C Print results of last sibship and do parents of current sibship
          if (fa(i).ne.currf .or. mo(i).ne.currm) then
            if (err) then
              if (nall.gt.4) errtyp=14
C Temporarily put back deleted genotype if errtyp=11
              if (badchild.ne.MISS) then
                locus(badchild,gene)=float(bad1)
                locus(badchild,gen2)=float(bad2)
              end if
C
C print only the list of genotypes for the family if verbosity low
C otherwise a pedigree drawing
C
              call famerr(loc(j),gene,pedigree,id,fa,mo,sex,locus,
     &                  currf,currm,badchild,sta,i-1,errtyp,plevel)
C
C And delete genotype if errtyp=11 or family if errtyp>11
              if (droperr.gt.0 .and. errtyp.ge.11) then
                call remfam(currf,currm,sta,i-1,gene,locus,ndiscard)
              end if
              err=.false.
            end if 
C initialize current sibship
            errtyp=0
            badchild=MISS
            sta=i
            nkids=0
            currf=fa(i)
            currm=mo(i)
            p11=int(locus(currf,gene))
            p12=int(locus(currf,gen2))
            p21=int(locus(currm,gene))
            p22=int(locus(currm,gen2))
            nall=0
            ptyped=0
            if (p11.gt.KNOWN) then
              ptyped=ptyped+1
              call addall(p11,nall,allele)
              call addall(p12,nall,allele)
            end if
            if (p21.gt.KNOWN) then
              ptyped=ptyped+2
              call addall(p21,nall,allele)
              call addall(p22,nall,allele)
            end if
          end if
C
C do current child if typed
C
          if (locus(i,gene).gt.KNOWN) then
            thiserr=.false.
            c1=int(locus(i,gene))
            c2=int(locus(i,gen2))
            nkids=nkids+1
            xmale(nkids)=(xlinkd .and. sex(i).eq.1)
            set(nkids,1)=c1
            set(nkids,2)=c2
C
C test for simple parent-offspring inconsistency
C if single error, try deleting just child
C
            if ((ptyped.eq.3 .and.
     2        parcon(c1,c2,p11,p12,p21,p22,xmale(nkids)).eq.0) .or.
     3        (ptyped.eq.1 .and. .not.xmale(nkids) .and. 
     4                           .not.opcon(c1,c2,p11,p12)) .or.
     5        (ptyped.eq.2 .and. .not.opcon(c1,c2,p21,p22))) then
              thiserr=.true.
              if (errtyp.eq.0) then
                errtyp=11
                badchild=i
                bad1=c1
                bad2=c2
                locus(i,gene)=MISS
                locus(i,gen2)=MISS
              elseif (errtyp.eq.11) then
                errtyp=12
              end if
C or too many alleles segregating in sibship
            else
              call addall(c1,nall,allele)
              call addall(c2,nall,allele)
              if (nall.gt.4 .or. (xlinkd .and. nall.gt.3)) then
                thiserr=.true.
                errtyp=14
C else test for more complex errors
              elseif (.not.err .and. ptyped.ne.3 .and. nkids.gt.1) 
     &        then
                call nuchek(xlinkd,ptyped,p11,p12,p21,p22,
     &                 nkids,set,xmale,nall,allele,thiserr)
                errtyp=13
              end if
            end if
C If an error, note the responsible child
            if (thiserr) then
              err=.true.
              if (droperr.eq.0) inconsist=inconsist+1
              call wrgtp(c1,c2,gtp,1)
              write(*,'(/9a/)') 'NOTE:  Inconsistency due child ',
     2          pedigree(1:eop),'-',id(i)(1:eow(id(i))),
     3          ' at locus ',loc(j),' {',gtp,'}'
            end if
          end if
   20   continue
C
C Last sibship 
C
        if (err) then
          if (nall.gt.4) errtyp=14
          if (badchild.ne.MISS) then
            locus(badchild,gene)=float(bad1)
            locus(badchild,gen2)=float(bad2)
          end if
          call famerr(loc(j),gene,pedigree,id,fa,mo,sex,locus,
     &                currf,currm,badchild,sta,i-1,errtyp,plevel)
          if (droperr.gt.0 .and. errtyp.ge.11) then
            call remfam(currf,currm,sta,i-1,gene,locus,ndiscard)
          end if
        end if 
      end if
   10 continue
      return
      end
C end-of-check
C
C identify parental alleles in nuclear family
C
      subroutine addall(iall,nall,allele)
      integer iall
      integer nall, allele(5)
      integer i
C find a match      
      do 10 i=1,nall
      if (iall.eq.allele(i)) then
        return
      end if
   10 continue
C else create new allele entry
      nall=nall+1
      if (nall.le.4) allele(nall)=iall
      return
      end
C end-of-addall
C
C nuclear family consistency check (untyped parents)
C
      subroutine nuchek(xlinkd,ptyped,p11,p12,p21,p22,
     &                  nkids,set,xmale,nall,allele,thiserr)
      integer KNOWN, MAXALL, MAXSIZ, MAXLOC, MISS
      parameter(KNOWN=0, MAXALL=60, MAXSIZ=1000,  
     &          MAXLOC=120, MISS=-9999)
      integer p11, p12, p21, p22, ptyped
      logical thiserr, xlinkd
C Pedigree structure
      integer nkids
      integer set(MAXSIZ,2)  
      logical xmale(MAXSIZ)
C
C count of segregating alleles, and frequency
      integer nall, allele(5)
C other local variables
      integer g1,g2,g3,g4
      integer i,mg1,mg2,pg1,pg2
      integer i1,i2,t1,t2
C functions
      integer parcon, whall
C
C While loop to list all possible genotypes
C initialize genotype indices
C
      if (ptyped.eq.1) then
        t1=1
        i1=1
        g1=whall(p11,nall,allele)
        g2=whall(p12,nall,allele)
      else
        t1=nall*(nall+1)/2
        i1=0
        g1=1
        g2=0
      end if
      if (ptyped.eq.2) then
        t2=1
        i2=1
        g3=whall(p21,nall,allele)
        g4=whall(p22,nall,allele)
      else
        t2=nall*(nall+1)/2
        i2=t2
        g3=1
        g4=0
      end if
C
C simulated nested do-loops
C check if inner loop completed once
C
      thiserr=.true.
  100 continue
        if (i2.eq.t2) then
          call couple(i1,t1,nall,g1,g2)
          pg1=allele(g1)
          pg2=allele(g2)
          if (xlinkd) pg2=pg1
          if (t2.gt.1) i2=0
        end if
        call couple(i2,t2,nall,g3,g4)
        mg1=allele(g3)
        mg2=allele(g4)
C       write(*,*) 'fa: ',pg1,'/',pg2,' ', mg1,'/', mg2
        do 10 i=1, nkids
C         write(*,*) 'Child ',i,' ',set(i,1),'/',set(i,2),' parcon=',
C    &      parcon(set(i,1),set(i,2),pg1,pg2,mg1,mg2,xmale(i))
        if (parcon(set(i,1),set(i,2),pg1,pg2,mg1,mg2,xmale(i)).eq.0) 
     &  then
          goto 55
        end if
   10   continue
C else (if consistent) return good news
          thiserr=.false.
          return
   55   continue
C end of while loop
      if (i1.ne.t1 .or. i2.ne.t2) goto 100
      return
      end
C end-of-nuchek
C
C Write out nuclear family error
C
      subroutine famerr(locnam,gene,pedigree,id,fa,mo,sex,locus,
     &                  currf,currm,badchild,sta,fin,errtyp,plevel)
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)

      integer badchild,currf,currm,errtyp,fin,gene,plevel,sta

      character*10 locnam
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer i, eop, gen2  
C
C functions
      integer eow
C
      eop=eow(pedigree)
      gen2=gene+1

      if (plevel.ge.0) then
        call describe(locnam,gene,pedigree,id,fa,mo,sex,locus,
     &                currf,currm,sta,fin,errtyp)
      else
        call inderr(pedigree, eop, id(currf), locnam, 
     &            int(locus(currf,gene)),int(locus(currf,gen2)))
        call inderr(pedigree, eop, id(currm), locnam, 
     &            int(locus(currm,gene)),int(locus(currm,gen2)))
        if (badchild.ne.MISS) then
           call inderr(pedigree, eop, id(badchild), locnam, 
     &            int(locus(badchild,gene)),int(locus(badchild,gen2)))
        else
          do 5 i=sta,fin
            call inderr(pedigree, eop, id(i), locnam, 
     &             int(locus(i,gene)),int(locus(i,gen2)))
    5     continue
        end if
      end if
      return
      end
C end-of-famerr
C
C write genotype for an individual flagged as a Mendelian error
C
      subroutine inderr(pedigree, eop, cid, locnam, all1, all2)
      integer MISS
      parameter (MISS=-9999)
      integer all1, all2, eop
      character*10 pedigree
      character*10 locnam
      character*8 cid
      character*7 gtp
C
      if (all1.eq.MISS) return

      call wrgtp(all1, all2, gtp,1)
      write(*,'(3a,1x,a,1x,2a)') pedigree(1:eop),'-',cid,
     &      locnam, gtp, ' Possible Mendelian error'
      return
      end
C end-of-inderr
C
C Drop a genotype from data if causing inconsistency
C
      subroutine remove(idx,gene,locus,ndiscard)

      integer KNOWN,MAXLOC,MAXSIZ,MISS
      parameter (KNOWN=0,MAXLOC=120,MAXSIZ=1000,MISS=-9999)
      integer gene, idx, ndiscard
      real locus(MAXSIZ,MAXLOC)
C
      if (locus(idx,gene).gt.KNOWN) then
        ndiscard=ndiscard+1
        locus(idx,gene)=MISS
        locus(idx,gene+1)=MISS
      end if
      return
      end
C end-of-remove
C
C drop a nuclear family's genotypes
C
      subroutine remfam(currf,currm,sta,fin,gene,locus,ndiscard)

      integer MAXLOC,MAXSIZ
      parameter (MAXLOC=120,MAXSIZ=1000)
      integer currf, currm, fin, gene, ndiscard, sta
      real locus(MAXSIZ,MAXLOC)

      integer i

      call remove(currf,gene,locus,ndiscard)
      call remove(currm,gene,locus,ndiscard)
      do 10 i=sta,fin
        call remove(i,gene,locus,ndiscard)
   10 continue
      return 
      end
C end-of-remfam
C
C set an entire family's genotypes to uninformative
C
      subroutine setall(gene,num,locus,val)
      integer MAXLOC,MAXSIZ
      parameter (MAXLOC=120,MAXSIZ=1000)
      integer gene
      real val, locus(MAXSIZ,MAXLOC)

      integer gen2, i
      
      gen2=gene+1
      do 10 i=1, num
        locus(i,gene)= val
        locus(i,gen2)= val
   10 continue
      return 
      end
C end-of-remall
C
C If Lange-Goradia algorithm not used, initialize genotypes for random walk
C algorithms via a conditional gene dropping algorithm
C
      subroutine start(locnam,xlinkd,gene,pedigree,num,nfound,
     2                 id,fa,mo,sex,locus,numal,name,cumfrq,
     3                 set,sibd,key,inconsist,plevel)
      integer MAXLOC, MAXSIZ, MISS, MAXALL
      parameter(MAXLOC=120, MAXSIZ=1000, MISS=-9999, MAXALL=60)
      integer gene, inconsist, plevel
C
C  Pedigree structure
      character*10 pedigree
      integer num,nfound 
      character*8 id(MAXSIZ) 
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C allele frequencies structure
      character*10 locnam
      logical xlinkd
      integer numal, name(MAXALL)
      double precision cumfrq(MAXALL)
      integer set(MAXSIZ,2), key(2*MAXSIZ), sibd(MAXSIZ,2)
C local variables
      integer found, g1, g2, gen2, i, failid, maxtry, restart
      logical fin
C functions
      integer eow, getnam


      found=0
      gen2=gene+1
      failid=MISS
      maxtry=5000
      do 5 i=1, num
        if (locus(i,gene).lt.0) then
          g1=MISS
          g2=MISS
        else
          g1=getnam(locus(i,gene),numal,name)
          g2=getnam(locus(i,gen2),numal,name)
        end if
        call update(i,g1,g2,set)
    5 continue
      do 10 i=1,nfound
        found=found+1
        sibd(i,1)=found
        found=found+1
        sibd(i,2)=found
   10 continue
C
C start of loop -- terminated by either a successful simulation
C of ibd, or bailout due <maxtry> iterations without success
C
      restart=0
   40 continue
        found=0
        do 45 i=1,nfound
          found=found+1
          key(found)=set(i,1)
          found=found+1
          key(found)=set(i,2)
   45   continue
        do 46 i=nfound+1,num
          sibd(i,1)=MISS
          sibd(i,2)=MISS
   46   continue

   50   continue
          fin=.true.
          do 70 i=nfound+1,num
          if (sibd(i,1).eq.MISS) then
            if (sibd(fa(i),1).ne.MISS .and. sibd(mo(i),1).ne.MISS) then
              call genof3(i,fa(i),mo(i),set,sibd,key,failid)
              if (failid.ne.MISS) then
                if (restart.lt.maxtry) then
                  restart=restart+1
                  if (plevel.gt.1) 
     2              write(*,*) 'Restart ',restart,' due to person ',
     3                id(failid),set(i,1),set(i,2)
                  goto 40
                else
                  write(*,'(4a/7x,3a,3(/7x,a)/)') 
     2    'ERROR: Unable to generate starting genotypes at locus ',
     3    locnam(1:eow(locnam)),' for pedigree ', pedigree,
     4    'due to parent(s) of person ',id(failid)(1:eow(id(failid))),
     5    '.','This is either due to a Mendelian inconsistency, ',
     6    'or because the pedigree is very large,',
     7    'in which case it may disappear if the job is rerun.'

                  inconsist=inconsist+1
                  return
                end if
              end if
            else
              fin=.false.
            end if
          end if
   70     continue
      if (.not.fin) goto 50
C
      call fillin(num,nfound,set,sibd,key,name,cumfrq,gene,locus)
      return
      end
C end-of-start
C
C  Drop ibd-alleles conditional on observed markers
C  and randomly where marker genotype not observed -- restart
C  if later generates inconsistency
C 
      subroutine genof3(idx,fa,mo,set,sibd,key,failid)
      integer MAXSIZ, MISS
      parameter(MAXSIZ=1000, MISS=-9999)
      integer idx,fa,mo,failid
      integer set(MAXSIZ,2),sibd(MAXSIZ,2),key(2*MAXSIZ)
      integer a1,a2,first,maxtrials,second,tr1,tr2,trials
C sample without replacement from {{1,2},{1,2},{1,2}}
      integer choice, seed, space(8)
C functions
      integer irandom
C
      failid=MISS
      maxtrials=8
      trials=0
      do 10 i=1,maxtrials
        space(i)=i
   10 continue

    1 continue

      trials=trials+1
      choice=irandom(trials, maxtrials)
      seed=space(choice)
      space(choice)=space(trials)

#ifdef F2C
      tr1=and(seed,4)/4+1
      tr2=and(seed,2)/2+1
      first=and(seed,1)+1
#endif F2C
#ifdef HPUX
      tr1=iand(seed,4)/4+1
      tr2=iand(seed,2)/2+1
      first=iand(seed,1)+1
#endif HPUX
#ifdef DEC
      tr1=iand(seed,4)/4+1
      tr2=iand(seed,2)/2+1
      first=iand(seed,1)+1
#endif DEC
#ifdef SUN
      tr1=and(seed,4)/4+1
      tr2=and(seed,2)/2+1
      first=and(seed,1)+1
#endif SUN

      second=3-first
      a1=sibd(fa,tr1)
      a2=sibd(mo,tr2)

      if (set(idx,1).eq.MISS) then
        sibd(idx,1)=a1
        sibd(idx,2)=a2
      elseif (key(a1).eq.MISS .and. key(a2).eq.MISS) then
        key(a1)=set(idx,first)
        key(a2)=set(idx,second)
        sibd(idx,1)=a1
        sibd(idx,2)=a2
      elseif (key(a1).eq.MISS .and. (set(idx,1).eq.key(a2) .or.
     &        set(idx,2).eq.key(a2))) then
        if (set(idx,1).eq.key(a2)) then
          key(a1)=set(idx,2)
          sibd(idx,1)=a2
          sibd(idx,2)=a1
        else
          key(a1)=set(idx,1)
          sibd(idx,1)=a1
          sibd(idx,2)=a2
        end if
      elseif (key(a2).eq.MISS .and. (set(idx,1).eq.key(a1) .or.
     &        set(idx,2).eq.key(a1))) then
        if (set(idx,1).eq.key(a1)) then
          key(a2)=set(idx,2)
          sibd(idx,1)=a1
          sibd(idx,2)=a2
        else
          key(a2)=set(idx,1)
          sibd(idx,1)=a2
          sibd(idx,2)=a1
        end if
      elseif (set(idx,1).eq.key(a1) .and. 
     &        set(idx,2).eq.key(a2)) then
        sibd(idx,1)=a1
        sibd(idx,2)=a2
      elseif (set(idx,1).eq.key(a2) .and. 
     &        set(idx,2).eq.key(a1)) then
        sibd(idx,1)=a2
        sibd(idx,2)=a1
      elseif (trials.lt.maxtrials) then
        goto 1
      else
        failid=idx
      end if
      return
      end
C end-of-genof3
C
C infer missing genotypes based on sibd values after run of start
C
      subroutine fillin(num,nfound,set,sibd,key,name,cumfrq,gene,locus)
      integer MAXALL, MAXLOC, MAXSIZ, MISS
      parameter(MAXALL=60, MAXLOC=120, MAXSIZ=1000, MISS=-9999)
      integer gene
C  Pedigree structure
      integer num, nfound, set(MAXSIZ,2), sibd(MAXSIZ,2), key(2*MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C  Cumulative allele frequencies
      integer name(MAXALL)
      double precision cumfrq(MAXALL)
C local variables
      integer g1,g2,gen2,i,tmp

      gen2=gene+1
      do 1 j=1,2*nfound
      if (key(j).eq.MISS) then
        do 2 i=1,num
        if (sibd(i,1).eq.j .and. set(i,1).ne.MISS) then
          key(j)=set(i,1)
        elseif (sibd(i,2).eq.j .and. set(i,2).ne.MISS) then
          key(j)=set(i,2)
        end if
    2   continue
        if (key(j).eq.MISS) then
          call found(cumfrq,g1)
          key(j)=g1
        end if
      end if
    1 continue
C
      do 5 i=1,num
      if (set(i,1).eq.MISS) then
        g1=name(key(sibd(i,1)))
        g2=name(key(sibd(i,2)))
        if (g1.gt.g2) then
          locus(i,gene)=-float(g2)
          locus(i,gen2)=-float(g1)
          tmp=sibd(i,1)
          sibd(i,1)=sibd(i,2)
          sibd(i,2)=tmp
        else
          locus(i,gene)=-float(g1)
          locus(i,gen2)=-float(g2)
        end if
      end if
    5 continue
      return
      end
C end-of-fillin
C
C Excluding genotypes from parental phenoset
C Straight Lange & Goradia AJHG 1987 40: 250-256
C
      subroutine exclude(imp,locnam,xlinkd,gene,pedigree,num,nfound,
     2               id,fa,mo,sex,locus,numal,name,alfrq,set,
     3               ngeno,gset,inconsist,imputd,plevel)
      integer MAXALL,MAXG,MAXLOC,MAXSIZ,MISS,KNOWN
      parameter (MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2, MAXLOC=120,
     &           MAXSIZ=1000, MISS=-9999,KNOWN=0)
      integer imp,gene,inconsist,imputd,plevel 
C Pedigree structure
      character*10 pedigree
      integer num,nfound 
      character*8 id(MAXSIZ) 
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C allele frequencies structure
      character*10 locnam
      logical xlinkd
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C phenoset arrays - parents and propositus; set() carries ngeno's for ped
C if set(pos,2) is nonzero, skip this sibship to pos=set(pos,2)
C 
      integer set(MAXSIZ,2)
      integer ngeno, gset(MAXSIZ,MAXG,2)
C local variables
C currin=prior no. of errors; currf and currm=current parents
C sta,fin=boundaries of current sibship; mxgeno=commonest genotype
C gfrq=genotype freq; mult=2 if heterozygote; mxfrq=freq of commonest geno
C
      integer currin,currf,currm,sta,fin,gen2,mxgeno
      double precision gfrq,mult,mxfrq
C functions 
      integer eow
      double precision getfreq
C
      currin=inconsist
C
C initialize phenosets
      gen2=gene+1
      do 160 i=1,num
        if (locus(i,gene).ne.MISS) then
          set(i,1)=1
          gset(i,1,1)=int(locus(i,gene))
          gset(i,1,2)=int(locus(i,gen2))
        elseif (xlinkd .and. sex(i).eq.1) then
          ngeno=0
          do 165 j=1,numal
            ngeno=ngeno+1
            gset(i,ngeno,1)=name(j)
            gset(i,ngeno,2)=name(j)
  165     continue
          set(i,1)=ngeno
        else
          ngeno=0
          do 170 j=1,numal
          do 170 k=j,numal
            ngeno=ngeno+1
            gset(i,ngeno,1)=name(j)
            gset(i,ngeno,2)=name(k)
  170     continue
          set(i,1)=ngeno
        end if
        set(i,2)=0
  160 continue
C
C locate beginnings and ends of sibships
      sta=nfound+1
      currf=fa(sta)
      currm=mo(sta)
      do 175 i=nfound+1,num
      if (fa(i).ne.currf .or. mo(i).ne.currm) then
        currf=fa(i)
        currm=mo(i)
        set(sta,2)=i
        sta=i
      end if
  175 continue
C last is special case
      set(sta,2)=num+1   
C
C loop through all nuclear families until all phenosets finalised
C
      call exc(locnam,xlinkd,gene,pedigree,num,nfound,
     2         id,fa,mo,sex,locus,set,ngeno,gset,
     3         currf,currm,sta,fin,inconsist,plevel)
C
C update workfile (compulsory since this replaces old workfile)
C
      if (inconsist.gt.currin) then
        call setall(gene,num,locus,-float(name(1)))
        return
      else if (imp.eq.2 .or. imp.eq.4) then
        do 190 i=nfound+1,num
        if (set(i,2).ne.0) then
          currf=fa(i)
          currm=mo(i)
          if (set(currf,1).eq.2.and.set(currm,1).eq.2) then
            if (gset(currf,1,1).eq.gset(currm,1,1) .and. 
     2          gset(currf,1,2).eq.gset(currm,1,2) .and.
     3          gset(currf,2,1).eq.gset(currm,2,1) .and. 
     4          gset(currf,2,2).eq.gset(currm,2,2) ) 
     5      then
              imputd=imputd+2
              if (plevel.gt.0) then
                write(*,'(/a,i5,a,i5,2a/7x,3a,2(a,i3,a1,i3)/)')
     2            'NOTE:  Imputed spouses ',id(currf),' and ',id(currm),
     3            ' in pedigree ',pedigree(1:eow(pedigree)),
     4            'at locus "',locnam(1:eow(locnam)),'"',' to be ',
     5            gset(currf,1,1),'/',gset(currf,1,2),' and ',
     6            gset(currf,2,1),'/',gset(currf,2,2)
              end if
              locus(currf,gene)= -float(gset(currf,1,1))
              locus(currf,gen2)= -float(gset(currf,1,2))
              locus(currm,gene)= -float(gset(currf,2,1))
              locus(currm,gen2)= -float(gset(currf,2,2))
            end if
          end if
        end if
  190   continue
      end if
C
C write out phenosets for untyped individuals and update imputed loci
C
      do 195 i=1,num
      if (locus(i,gene).le.KNOWN) then
        ngeno=set(i,1)
        if (ngeno.eq.1) then
          imputd=imputd+1
          if (plevel.gt.0) then
            write(*,'(/7a,i3,a1,i3/)')
     2        'NOTE:  Imputed person ',pedigree(1:eow(pedigree)),'-',
     3        id(i)(1:eow(id(i))),' at locus "',locnam(1:eow(locnam)),
     4        '" to be ', gset(i,1,1),'/',gset(i,1,2)
          end if
          locus(i,gene)=float(gset(i,1,1))
          locus(i,gen2)=float(gset(i,1,2))
        end if
      end if
  195 continue
      if (plevel.gt.1) then
        call wrset(locnam,pedigree,num,id,set,gset)
      end if
C
C Now sequentially initialise so-far untyped individuals to be a 
C likely genotype.  Move through the pedigree, impute
C the current untyped individual, prune genotypes for the remaining
C untyped individuals thus made illegal, until end of pedigree.
C Denote initialised genotypes with negative allele values.
C
C Do not perform sequential imputation if Mendelian errors detected or imp>3.
C
C If failure of sequential imputation, switch to MC start() algorithm
C
      if (imp.gt.3 .or. inconsist.gt.currin) return

      do 200 i=1,num
        if (set(i,1).gt.1) then
          ngeno=set(i,1)
          mxfrq=0.0d0
          do 210 j=1,ngeno
            mult=2.0d0
            if (gset(i,j,1).eq.gset(i,j,2)) mult=1.0d0
            gfrq= mult*getfreq(gset(i,j,1),numal,name,alfrq)*
     &            getfreq(gset(i,j,2),numal,name,alfrq)
            if (gfrq.gt.mxfrq) then
              mxfrq=gfrq
              mxgeno=j
            end if
  210     continue
          locus(i,gene)= -float(gset(i,mxgeno,1))
          locus(i,gen2)= -float(gset(i,mxgeno,2))
          set(i,1)=1
          gset(i,1,1)= gset(i,mxgeno,1)
          gset(i,1,2)= gset(i,mxgeno,2)
          call exc(locnam,xlinkd,gene,pedigree,num,nfound,
     2             id,fa,mo,sex,locus,set,ngeno,gset,
     3             currf,currm,sta,fin,inconsist,-2)
C
C if only one genotype in phenoset but locus not yet updated then update
        elseif (locus(i,gene).eq.MISS) then
          locus(i,gene)= -float(gset(i,1,1))
          locus(i,gen2)= -float(gset(i,1,2))
        end if
C
C check for failure of algorithm -- may need to switch to start()
        if (inconsist.gt.currin) then
          inconsist=currin
          imp=imp+3
          return
        end if
  200 continue
      return      
      end
C end-of-exclude
C
C write out phenoset
C
      subroutine wrset(locnam,pedigree,num,id,set,gset)
      integer MAXALL,MAXG,MAXSIZ
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXSIZ=1000)
      integer num,set(MAXSIZ,2)
      character*8 id(MAXSIZ)
      integer gset(MAXSIZ,MAXG,2)
      character*10 pedigree
      character*10 locnam
      integer i,j,ngeno
C functions
      integer eow
      write(*,'(/4a/a/a)') 
     2  'Phenosets for locus ',locnam(1:eow(locnam)),
     3  ' in pedigree ',pedigree, 'ID       Count    Legal Genotypes',
     4                            '-------- -------- ---------------'
      do 10 i=1,num
        ngeno=set(i,1)
        write(*,'(a8,1x,i8,7(1x,i3,a1,i3):)') id(i),ngeno,
     &    (gset(i,j,1),'/',gset(i,j,2),j=1,min(ngeno,7))
   10 continue
      write(*,*)
      return
      end
C end-of-wrset
C
C perform exclusion for the pedigree regardless of imputation level
C
      subroutine exc(locnam,xlinkd,gene,pedigree,num,nfound,
     2               id,fa,mo,sex,locus,set,ngeno,gset,
     3               currf,currm,sta,fin,inconsist,plevel)
      integer MAXALL,MAXG,MAXSIZ,MAXLOC
      parameter (MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXSIZ=1000,
     &           MAXLOC=120)
      integer gene, sta, fin, currf, currm, inconsist, plevel
      logical xlinkd
C part of pedigree structure
      character*10 locnam, pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C pointers to sibships
      integer set(MAXSIZ,2)
C arrays to contain full phenosets for all pedigree members
      integer ngeno,gset(MAXSIZ,MAXG,2)
C local variables
      logical change,complete
      integer it,incon
C functions
      integer eow
C
      it=0
    1 continue
        change=.false.
        complete=.true.
        sta=nfound+1
        it=it+1
        if (plevel.gt.2) then
          write(*,'(/5a,i2/)') 'Pedigree ',pedigree,' locus ',locnam,
     &     ' Iteration ',it
        end if
C
C One iteration of pedigree - sibship by sibship
C
    5   continue
        if (sta.gt.num) goto 15
        if (set(sta,2).lt.0) then
           sta=-set(sta,2)
           goto 5
         end if
          currf=fa(sta)
          currm=mo(sta)
          fin=set(sta,2)-1
          if (plevel.gt.2) then
            write(*,'(4(a,a8))') 
     2        'Nuclear family: ',id(currf),' x ',id(currm),
     3        '   Off: ',id(sta),' to ',id(fin)
          end if
          incon=0
          call landg(xlinkd,sta,fin,sex,set,ngeno,gset,currf,currm,
     &               change,incon)
C
C check to see if completely unambiguous -- skip in future if true
C
          complete=.true.
          if (set(currf,1).gt.1.or.set(currm,1).gt.1) then
            complete=.false.
          else
            do 25 i=sta,fin
            if (set(i,1).gt.1) then
              complete=.false.
              goto 26
            end if
   25       continue
   26       continue
          end if
          if (complete) set(sta,2)=-fin-1
C
C Check for inconsistencies.
C If being used to generate starting genotypes, 
C don't print a worrying message.
C Old behaviour was to continue looking for errors, but probably cheapest
C to bail out now, as most are fall-out from the first inconsistency.
C
          if (incon.gt.0) then
            inconsist=inconsist+incon
            if (plevel.gt.-2) then
              write(*,'(/5a/)') 
     2          'NOTE:  Mendelian inconsistency in pedigree ',
     3           pedigree(1:eow(pedigree)),' at locus "',
     4           locnam(1:eow(locnam)),'".'
              call describe(locnam,gene,pedigree,id,fa,mo,sex,locus,
     &                      currf,currm,sta,fin,10)
              call famset(pedigree,currf,currm,sta,fin,gene,num,nfound,
     &                    id,fa,mo,locus,set,gset)
            end if
            return
          end if
C increment to next sibship
          sta=fin+1
        
        goto 5
   15   continue
C
C end of iteration through pedigree
        if (plevel.gt.2) then
          call wrset(locnam,pedigree,num,id,set,gset)
        end if
      if (change) goto 1
      return
      end
C end-of-exc
C
C 2nd version of impute -- following Lange & Goradia, 1987
C
      subroutine landg(xlinkd,sta,fin,sex,set,ngeno,gset,currf,currm,
     &                 change,incon)

      integer MAXALL,MAXG,MAXSIZ
      parameter (MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXSIZ=1000)
      integer sta, fin, currf, currm
      integer sex(MAXSIZ), set(MAXSIZ,2)
      integer ngeno,gset(MAXSIZ,MAXG,2)
      logical chachi,change,con,pcon,xlinkd,xmale
C
      logical keep(MAXG),keep2(MAXG)
      integer i,j,k,l,ngeno1,ngeno2,totgen
C functions
      integer parcon
C
      xmale=.false.
      ngeno1=set(currf,1)
      ngeno2=set(currm,1)
      totgen=ngeno1+ngeno2
C
C first prune parental genotypes inconsistent with children
C
      do 5 j=1,ngeno1
    5   keep(j)=.false.
      do 6 k=1,ngeno2
    6   keep2(k)=.false.
      do 10 j=1,ngeno1
      do 10 k=1,ngeno2
        pcon=.true.
        do 15 i=sta,fin
          ngeno=set(i,1)
          xmale=(xlinkd .and. sex(i).eq.1)
          con=.false.
          do 16 l=1,ngeno
          if (parcon(gset(i,l,1),gset(i,l,2),gset(currf,j,1),
     2        gset(currf,j,2),gset(currm,k,1),gset(currm,k,2),
     3        xmale).gt.0) then
            con=.true.
          end if
   16     continue
          if (.not.con) then
            pcon=.false.
            goto 17
          end if
   15   continue
   17   continue
C
C save this parental genotype if consistent
C
        if (pcon) then
          keep(j)=.true.
          keep2(k)=.true.
        end if
   10 continue
      call prune(currf,ngeno1,gset,keep)
      call prune(currm,ngeno2,gset,keep2)
      if (totgen.ne.(ngeno1+ngeno2)) then
        change=.true.
        set(currf,1)=ngeno1
        set(currm,1)=ngeno2
        if (ngeno1.eq.0) then
          incon=incon+1
        end if
        if (ngeno2.eq.0) then
          incon=incon+1
        end if
      end if
C
C then examine each child's phenoset and remove genotypes inconsistent
C with the current parental phenosets
C
      do 25 i=sta,fin
        ngeno=set(i,1)
        xmale=(xlinkd .and. sex(i).eq.1)
        if (ngeno.gt.1) then
          do 26 l=1,ngeno
            keep(l)=.false.
            do 26 j=1,ngeno1
            do 26 k=1,ngeno2
            if (parcon(gset(i,l,1),gset(i,l,2),gset(currf,j,1),
     2          gset(currf,j,2),gset(currm,k,1),gset(currm,k,2),
     3          xmale).gt.0) then
              keep(l)=.true.
            end if
   26     continue
C see if any alterations made
          chachi=.false.
          do 27 l=1,ngeno
          if (.not.keep(l)) then
            chachi=.true.
            goto 28
          end if
   27     continue
   28     continue
          if (chachi) then
            change=.true.
            call prune(i,ngeno,gset,keep)
            set(i,1)=ngeno
            if (ngeno.eq.0) then
              incon=incon+1
            end if
          end if
        end if
   25 continue
      return
      end
C end-of-landg
C
C remove unwanted genotypes from phenoset
C
      subroutine prune(idx,ngeno,gset,keep)
      integer MAXALL,MAXG,MAXSIZ
      parameter (MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXSIZ=1000)
      integer idx, ngeno, gset(MAXSIZ,MAXG,2)
      logical keep(MAXG)
      integer old,nkept
      nkept=0
      do 20 old=1,ngeno
      if (keep(old)) then
        nkept=nkept+1
        if (nkept.ne.old) call swapg(idx,gset,old,nkept)
      end if
   20 continue
C Mark end of old phenoset, so can print out if later needed
      gset(idx,ngeno+1,1)=0
      ngeno=nkept
      return
      end
C end-of-prune
C
C swap two genotypes within a phenoset array
C
      subroutine swapg(idx,gset,j,k)
      integer MAXALL,MAXG,MAXSIZ
      parameter (MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXSIZ=1000)
      integer idx,j,k,gset(MAXSIZ,MAXG,2)
      integer tmp
      tmp=gset(idx,j,1)
      gset(idx,j,1)=gset(idx,k,1)
      gset(idx,k,1)=tmp
      tmp=gset(idx,j,2)
      gset(idx,j,2)=gset(idx,k,2)
      gset(idx,k,2)=tmp
      return
      end
C end-of-swapg
C
C Tests if child genotype consistent with parental genotypes:
C parcon=4*Pr(Child_genotype|Father_genotype,Mother_genotype)
C if xmale  TRUE then X-linked locus *and* male child
C
      integer function parcon(c1,c2,p11,p12,p21,p22,xmale)
      integer c1,c2,p11,p12,p21,p22
      logical xmale 
      parcon=0
      if (xmale) then
        if (c1.eq.p21) parcon=parcon+2
        if (c1.eq.p22) parcon=parcon+2
        return
      end if
      if ((c1.eq.p11 .and. c2.eq.p21) .or. (c1.eq.p21 .and. c2.eq.p11)) 
     &  parcon=parcon+1
      if ((c1.eq.p11 .and. c2.eq.p22) .or. (c1.eq.p22 .and. c2.eq.p11))
     &  parcon=parcon+1
      if ((c1.eq.p12 .and. c2.eq.p21) .or. (c1.eq.p21 .and. c2.eq.p12))
     &  parcon=parcon+1
      if ((c1.eq.p12 .and. c2.eq.p22) .or. (c1.eq.p22 .and. c2.eq.p12))
     &  parcon=parcon+1
      return
      end
C end-of-parcon
C
C test if child genotype consistent with one parental genotype
C
      logical function opcon(c1,c2,p1,p2)
      integer c1,c2,p1,p2
      opcon=.false.
      if (c1.eq.p1 .or. c1.eq.p2 .or. c2.eq.p1 .or. c2.eq.p2) 
     &  opcon=.true.
      return
      end
C end-of-opcon
C
C write out genotypes in nuclear family and grandparents
C
      subroutine describe(locnam,gene,pedigree,id,fa,mo,sex,locus,
     &                    currf,currm,sta,fin,mesg)
      integer MAXSIZ, MAXLOC, MISS, WIDE
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999, WIDE=12)

      integer currf, currm, fin, gene, mesg, sta
      character*10 locnam
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer i, eol, eop, gen2, leftm, npars, pos, nsibs
      logical gp1, gp2  
      character*7 gtp
      character*10 chid
      character*128 lin
C
C functions
      integer eow
C
C
C else
C
C Check if useful to view
C
      if (mesg.lt.10) then
        npars=0
        if (locus(currf,gene).ne.MISS) npars=npars+1
        if (locus(currm,gene).ne.MISS) npars=npars+1
        nsibs=0
        do 5 i=sta,fin
        if (locus(i,gene).ne.MISS) then
          nsibs=nsibs+1 
        end if
    5   continue
        if (nsibs.eq.0 .or. (nsibs.eq.1 .and. npars.eq.0)) return
      end if
C
C if useful
C
      gen2=gene+1
      eop=eow(pedigree)
      lin=' '
      write(*,'(3a/a)') 'Locus "',locnam(1:eow(locnam)),'"',
     &                  '------------------'
      write(*,'(8a/)')
     2  'Sibship: ',pedigree(1:eop),'-',id(currf)(1:eow(id(currf))),
     3  ' x ',pedigree(1:eop),'-',id(currm)(1:eow(id(currm))) 
C
C write an edifying message, if supplied
C
      if (mesg.eq.10) then
        write(*,'(a/)') 
     &    'Multigenerational inconsistency between genotypes.'
      elseif (mesg.eq.11) then
        write(*,'(a/)') 
     &    'Inconsistency between parent and child genotypes.'
      elseif (mesg.eq.12) then
        write(*,'(a/)') 
     &    'Multiple inconsistencies between parent and child genotypes.'
      elseif (mesg.eq.13) then
        write(*,'(a/)') 
     &    'Inconsistency between sibling genotypes.'
      elseif (mesg.eq.14) then
        write(*,'(a/)') 
     &    'More than 4 alleles segregating in nuclear family.'
      elseif (mesg.eq.15) then
        write(*,'(a/)') 
     &    'Inconsistency between imputed parent and child genotypes.'
      end if
      gp1=(fa(currf).ne.MISS)
      gp2=(fa(currm).ne.MISS)
C
C Show grandparental generation if useful and present
C
      if (mesg.lt.11 .and. (gp1 .or. gp2)) then
        if (gp1) then
          call wrid('c',id(fa(currf)),chid,sex(fa(currf)))
          lin(17:26)=chid
          call wrid('c',id(mo(currf)),chid,sex(mo(currf)))
          lin(27:36)=chid
          eol=36
        end if
        if (gp2) then
          call wrid('c',id(fa(currm)),chid,sex(fa(currm)))
          lin(37:46)=chid
          call wrid('c',id(mo(currm)),chid,sex(mo(currm)))
          lin(47:56)=chid
          eol=56
        end if
        write(*,'(a)') lin(1:eol)
        lin=' '
        if (gp1) then
          call wrgtp(int(locus(fa(currf),gene)),
     &               int(locus(fa(currf),gen2)),gtp,1)
          lin(18:24)=gtp
          call wrgtp(int(locus(mo(currf),gene)),
     &               int(locus(mo(currf),gen2)),gtp,1)
          lin(28:34)=gtp
          eol=34
        end if
        if (gp2) then
          call wrgtp(int(locus(fa(currm),gene)),
     &               int(locus(fa(currm),gen2)),gtp,1)
          lin(38:44)=gtp
          call wrgtp(int(locus(mo(currm),gene)),
     &               int(locus(mo(currm),gen2)),gtp,1)
          lin(48:54)=gtp
          eol=54
        end if
        write(*,'(a)') lin(1:eol)
        lin=' '
        if (gp1) then
          lin(21:21)='|'
          lin(31:31)='|'
          eol=31
        end if
        if (gp2) then
          lin(41:41)='|'
          lin(51:51)='|'
          eol=51
        end if
        write(*,'(a)') lin(1:eol)
        lin=' '
        if (gp1) then
          lin(21:31)='+====+====+'
          eol=31
        end if
        if (gp2) then
          lin(41:51)='+====+====+'
          eol=51
        end if
        write(*,'(a)') lin(1:eol)
        lin=' '
        if (gp1) then
          lin(26:26)='|'
          eol=26
        end if
        if (gp2) then
          lin(46:46)='|'
          eol=46
        end if
        write(*,'(a)') lin(1:eol)
        lin=' '
      end if
C
C Now the parents of the nuclear family
C
      call wrid('c',id(currf),chid,sex(currf))
      lin(22:31)=chid
      call wrid('c',id(currm),chid,sex(currm))
      lin(42:51)=chid
      write(*,'(a)') lin(1:50)
      lin=' '
      call wrgtp(int(locus(currf,gene)),int(locus(currf,gen2)),gtp,1)
      lin(23:29)=gtp
      call wrgtp(int(locus(currm,gene)),int(locus(currm,gen2)),gtp,1)
      lin(43:49)=gtp
      write(*,'(a)') lin(1:49)
      lin=' '
      write(*,'(25x,a1,19x,a1/25x,a21/35x,a1)')
     &  '|','|','+=========+=========+','|'
C
C Then the children
C
      nsibs=fin-sta+1
      if (nsibs.eq.1) then
        call wrid('c',id(sta),chid,sex(sta))
        call wrgtp(int(locus(sta,gene)),int(locus(sta,gen2)),gtp,1)
        write(*,'(35x,a1/31x,a10/32x,a7)') '|',chid,gtp
      elseif (nsibs.gt.WIDE) then
        do 10 i=sta,fin
          call wrgtp(int(locus(i,gene)),int(locus(i,gen2)),gtp,1)
          write(*,'(28x,a8,1x,a7)') id(i),gtp
   10   continue
      else
        leftm=max(3,38-5*nsibs)
        pos=leftm+3
        do 15 i=1,nsibs-1
          lin(pos:pos+10)='+---------+'
          pos=pos+10
   15   continue
        lin(36:36)='+'
        write(*,'(a)') lin(1:pos)
        lin=' '
        pos=leftm+3
        do 20 i=1,nsibs
          lin(pos:pos)='|'
          pos=pos+10
   20   continue
        write(*,'(a)') lin(1:pos)
        lin=' '
        pos=leftm-1
        do 25 i=sta,fin
          call wrid('c',id(i),chid,sex(i))
          lin(pos:pos+9)=chid
          pos=pos+10
   25   continue
        write(*,'(a)') lin(1:pos)
        lin=' '
        pos=leftm
        do 30 i=sta,fin
          call wrgtp(int(locus(i,gene)),int(locus(i,gen2)),gtp,1)
          lin(pos:pos+6)=gtp
          pos=pos+10
   30   continue
        write(*,'(a)') lin(1:pos)
      end if
      write(*,*)
      return
      end
C end-of-describe
C
C Write out phenoset for a nuclear family (plus grandparents and halfsibs)
C Useful in detecting sources of long distance Mendelian inconsistencies.
C
      subroutine famset(pedigree,currf,currm,sta,fin,gene,num,nfound,
     &                  id,fa,mo,locus,set,gset)
      integer MAXALL,MAXG,MAXLOC,MAXSIZ,MISS
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXLOC=120,
     &          MAXSIZ=1000,MISS=-9999)
      integer currf, currm, fin, gene, num, nfound, sta
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer set(MAXSIZ,2), gset(MAXSIZ,MAXG,2)

      integer g1,g2,gen2,gfa,gmo,i
      logical found
C functions
      logical allinset

      gen2=gene+1

      write(*,'(a/a)') 'ID       Count    Problem phenosets',
     &                 '-------- -------- -----------------'
C Grandparental phenosets
      if (fa(currf).ne.MISS) then
        write(*,'(/a)') 'Paternal Gparents'
        call indset(fa(currf),gene,id,locus,set,gset)
        call indset(mo(currf),gene,id,locus,set,gset)
      end if
      if (fa(currm).ne.MISS) then
        write(*,'(/a)') 'Maternal Gparents'
        call indset(fa(currm),gene,id,locus,set,gset)
        call indset(mo(currm),gene,id,locus,set,gset)
      end if
C Uncles and aunts phenosets
      if (fa(currf).ne.MISS) then
        gfa=fa(currf)
        gmo=mo(currf)
        found=.false.
        do 20 i=nfound+1,num
        if (fa(i).eq.gfa .and. mo(i).eq.gmo .and. i.ne.currf) then
          if (.not.found) then
            write(*,'(/a)') 'Paternal Uncles/Aunts'
            found=.true.
          end if
          call indset(i,gene,id,locus,set,gset)
        end if  
   20   continue
      end if
      if (fa(currm).ne.MISS) then
        gfa=fa(currm)
        gmo=mo(currm)
        found=.false.
        do 30 i=nfound+1,num
        if (fa(i).eq.gfa .and. mo(i).eq.gmo .and. i.ne.currm) then
          if (.not.found) then
            write(*,'(/a)') 'Maternal Uncles/Aunts'
            found=.true.
          end if
          call indset(i,gene,id,locus,set,gset)
        end if  
   30   continue
      end if
C Parental phenosets
      write(*,'(/a)') 'Father'
      call indset(currf,gene,id,locus,set,gset)
      write(*,'(/a)') 'Mother'
      call indset(currm,gene,id,locus,set,gset)
C Sibship phenosets
      write(*,'(/a)') 'Children'
      do 10 i=sta,fin
        call indset(i,gene,id,locus,set,gset)
   10 continue
C Half-sib phenosets
      found=.false.
      do 40 i=nfound+1,num
      if (fa(i).eq.currf .and. mo(i).ne.currm) then
        if (.not.found) then
          write(*,'(/a)') 'Paternal Half-sibs'
          found=.true.
        end if
        call indset(i,gene,id,locus,set,gset)
      end if  
   40 continue
      found=.false.
      do 50 i=nfound+1,num
      if (fa(i).ne.currf .and. mo(i).eq.currm) then
        if (.not.found) then
          write(*,'(/a)') 'Maternal Half-sibs'
          found=.true.
        end if
        call indset(i,gene,id,locus,set,gset)
      end if  
   50 continue
      write(*,*)
C
C See if single allele might explain inconsistency between untyped parent 
C and offspring
C
      do 100 i=sta,fin
      if (locus(i,gene).ne.MISS) then
        g1=int(locus(i,gene))
        g2=int(locus(i,gen2))
        if (set(currf,1).eq.0) then
          call cntbad(currf,ngeno,gset)
          if (.not.allinset(currf,g1,ngeno,gset)) then
            call wroddall(pedigree,id(currf),id(i),g1)
          end if
          if (.not.allinset(currf,g2,ngeno,gset)) then
            call wroddall(pedigree,id(currf),id(i),g1)
          end if
        end if
        if (set(currm,1).eq.0) then
          call cntbad(currm,ngeno,gset)
          if (.not.allinset(currm,g1,ngeno,gset)) then
            call wroddall(pedigree,id(currm),id(i),g1)
          end if
          if (.not.allinset(currm,g2,ngeno,gset)) then
            call wroddall(pedigree,id(currm),id(i),g2)
          end if
        end if
      end if
  100 continue
      write(*,*)
      return
      end
C end-of-famset
C
C write out phenoset for an individual 
C
      subroutine indset(idx,gene,id,locus,set,gset)
      integer MAXALL,MAXG,MAXLOC,MAXSIZ,MISS
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXLOC=120,
     &          MAXSIZ=1000,MISS=-9999)
      integer gene, idx, set(MAXSIZ,2)
      character*8 id(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer gset(MAXSIZ,MAXG,2)
      integer gen2,i,ngeno

      gen2=gene+1
      if (locus(idx,gene).ne.MISS) then
        write(*,'(a8,1x,a8,1x,i3,a1,i3)') id(idx),'Typed',
     &    int(locus(idx,gene)), '/', int(locus(idx,gen2))
      elseif (set(idx,1).eq.0) then
        call cntbad(idx,ngeno,gset)
        write(*,'(a8,1x,a8,7(1x,i3,a1,i3):)') id(idx),'Problem',
     &    (gset(idx,i,1),'/',gset(idx,i,2),i=1,min(ngeno,7))
      else
        ngeno=set(idx,1)
        write(*,'(a8,1x,i8,7(1x,i3,a1,i3):)') id(idx),ngeno,
     &    (gset(idx,i,1),'/',gset(idx,i,2),i=1,min(ngeno,7))
      end if
      return
      end
C end-of-indset
C
C see if particular allele in phenoset for idx person
C
      logical function allinset(idx,iall,ngeno,gset)
      integer MAXALL,MAXG,MAXSIZ
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXSIZ=1000)
      integer iall, idx, ngeno
      integer gset(MAXSIZ,MAXG,2)

      integer i

      allinset=.true.
      do 10 i=1,ngeno
      if (gset(idx,i,1).eq.iall .or. gset(idx,i,2).eq.iall) then
        return
      end if
   10 continue
C else if not found
      allinset=.false.
      return
      end
C end-of-allinset
C
C If phenoset contains zero legal genotypes, reconstruct last state
C
      subroutine cntbad(idx,ngeno,gset)
      integer MAXALL,MAXG,MAXSIZ
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MAXSIZ=1000)
      integer idx, ngeno
      integer gset(MAXSIZ,MAXG,2)
      integer i

      do 10 i=1,MAXG
        if (gset(idx,i,1).eq.0) then
          ngeno=i-1
          return 
        end if
   10 continue
      ngeno=0
      return
      end
C end-of-cntbad
C
C If find an odd-allele-out, write out its location
C
      subroutine wroddall(pedigree,parent,child,iall)
      character*10 pedigree
      character*8 parent, child
      integer iall
      integer eop
C functions
      integer eow

      eop=eow(pedigree)

      write(*,'(5a,i3,5a)') 'Parent ',pedigree(1:eop),'-',
     2  parent(1:eow(parent)), ' cannot carry the ',
     3  iall,' allele found in child ',
     4  pedigree(1:eop),'-',child(1:eow(child)),'.'
      return
      end
C end-of-wroddall
