
C
C Count alleles in entire sample -- codominant system
C Either unweighted or weighted by number of founders in pedigree
C
C If imputation has been done and fndr=2, then return the 
C count of alleles in the founders, both observed and imputed
C
      subroutine freq(wrk,gene,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                locus, numloc,numal,name,fndr,alfrq,typed)
      integer KNOWN,MAXSIZ,MAXLOC,MAXALL,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MAXALL=60,MISS=-9999)
C Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer fndr, numloc, gene, wrk, typed
      real locus(MAXSIZ,MAXLOC)
      logical last
C
C allele frequencies structure
      integer tfound, numal, name(MAXALL)
      double precision alfrq(MAXALL)
C
      integer action, den, gen2, i
      double precision wei

      action=fndr
      gen2=gene+1

C global restart if unimputed genotypes present and fndr=2
C
  999 continue

      numal=0
      typed=0
      tfound=0

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

       if (actset.le.0) goto 10
C
C Count observed alleles and skip if none
       den=0
       do 12 i=1,num
         if (locus(i,gene).gt.KNOWN) den=den+1
         if (locus(i,gen2).gt.KNOWN) den=den+1
   12  continue
       if (den.eq.0) goto 10
C
C If fndr=2 only count alleles in founders
C If fndr=1 weight count in this pedigree by number of founders
C
       tfound=tfound+nfound
       typed=typed+den
       wei=1.0d0
       if (action.eq.1) wei=dfloat(nfound)/dfloat(den)

       if (action.lt.2) then
         do 15 i=1,num
           if (locus(i,gene).gt.KNOWN) then
             call tab(int(locus(i,gene)),numal,name,alfrq,wei)
           end if
           if (locus(i,gen2).gt.KNOWN) then
             call tab(int(locus(i,gen2)),numal,name,alfrq,wei)
           end if
   15    continue
       else
         do 17 i=1,nfound
           if (locus(i,gene).ne.MISS) then
             call tab(int(abs(locus(i,gene))),numal,name,alfrq,wei)
           else
             action=0
             goto 999
           end if
           if (locus(i,gen2).ne.MISS) then
             call tab(int(abs(locus(i,gen2))),numal,name,alfrq,wei)
           else
             action=0
             goto 999
           end if
   17    continue
       end if
      goto 10
   20 continue

      if (action.gt.0) then
        wei=1.0d0/dfloat(action*tfound)
      else
        wei=1.0d0/dfloat(max(1,typed))
      end if
      do 30 i=1,numal
        alfrq(i)=wei*alfrq(i)
   30 continue
      return
      end
C end-of-freq
C
C update table of counts of alleles -- binary search and insertion sort
C
      subroutine tab(curr,numal,name,alfrq,wei)
      integer MAXALL
      parameter(MAXALL=60)
      integer curr, numal, name(MAXALL)
      double precision wei, alfrq(MAXALL)
      integer hi,i,lo,pos

      hi=numal
      lo=1

    1 continue 
      if (hi.lt.lo) goto 5
        pos=(hi+lo)/2
        if (curr.gt.name(pos)) then
          lo=pos+1
        elseif (curr.lt.name(pos)) then
          hi=pos-1
        else
          alfrq(pos)=alfrq(pos)+wei
          return
        end if
      goto 1
    5 continue
C else
      if (numal.lt.MAXALL) then
        do 2 i=numal,lo,-1
          name(i+1)=name(i)
          alfrq(i+1)=alfrq(i)
    2   continue
        numal=numal+1
        name(lo)=curr
        alfrq(lo)=wei
      else
        write(*,'(/a,i2,a/7x,a/)') 
     2    'ERROR: Number of alleles for locus exceeds ',MAXALL,
     3    ', the maximum allowed.','Stopping prematurely.'
        stop
      end if
      return
      end
C end-of-tab
C
C Write out frequencies
C
      subroutine wrfreq(strm,locus,numal,name,alfrq,mappos,
     &                  typed,nobs,fstyle)
      integer MAXALL
      parameter (MAXALL=60)
      character*10 locus
      integer fstyle, nobs, strm, typed
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C map position
      real mappos
C local variables
      integer i,j,nlines
      character*8 mentyp
      double precision corr,het,uninf

      if (fstyle.eq.1) then
        corr=1.0d0
        het=0.0d0
        uninf=0.0d0
        write(*,'(/a/a,a10,a/a/a)')
     2   '------------------------------------------------',
     3   'Allele frequencies for locus "',locus,'"',
     4   '------------------------------------------------',
     7   '   Allele  Frequency   Count  Histogram'
        if (numal.eq.0) then
          write(*,'(/6x,a)') 'No nonmissing genotypes'
        else
          do 25 i=1,numal
            write(*,'(4x,i4,5x,f6.4,4x,i5,2x,20a1:)') 
     2        name(i),alfrq(i),nint(float(typed)*alfrq(i)),
     3        ('*',j=1,max(1,nint(20.0d0*alfrq(i))))
            het=het+alfrq(i)*alfrq(i)
   25     continue
          do 27 i=1,numal-1
          do 27 j=i+1,numal
            uninf=uninf+2.0d0*alfrq(i)*alfrq(j)*alfrq(i)*alfrq(j)
   27     continue
          if (typed.gt.1) corr=dfloat(typed)/dfloat(typed-1)
          het=1.0d0-het
          write(*,'(/a,i4,2(/a,3x,f6.4)/a,i4,1x,a,f5.1,a)')
     2     'Number of alleles    = ',numal,
     3     'Heterozygosity (Hu)  = ',corr*het,
     4     'Poly. Inf. Content   = ',het-uninf,
     5     'Number persons typed = ',typed/2,
     6     '(',float(50*typed)/float(nobs),'%)'
        end if
C scratch file
      elseif (fstyle.eq.3) then
        write(strm) numal,(name(i),i=1,numal),(alfrq(i),i=1,numal)
C GAS locus file
      elseif (fstyle.eq.4) then
        call precis(numal,alfrq,4)
        write(strm,'(1x,i3,100(1x,f6.4):)') numal,(alfrq(i),i=1,numal)
        write(strm,'(1x,a,100(1x,i3):)') 'name ',(name(i),i=1,numal)
C SAGE locus file
      elseif (fstyle.eq.5) then
        call precis(numal,alfrq,4)
        write(strm,'(a10)') locus
        do 35 i=1,numal
   35     write(strm,'(1x,i4.4,a,f6.4)') name(i),' = ',alfrq(i)
        write(strm,'(1x,a1)') ';'
        do 40 i=1,numal
        do 40 j=i,numal
   40     write(strm,'(1x,4(i4.4,a))') 
     2       name(i),'/',name(j),' = {',name(i),'/',name(j),'}'
        write(strm,'(1x,a1)') ';'
C new style MENDEL locus file -- used by simwalk and relpair
      elseif (fstyle.eq.7 .or. fstyle.eq.10) then
        mentyp='AUTOSOME'
        if (fstyle.eq.10) mentyp='X-LINKED'
        call precis(numal,alfrq,6)
        write(strm,'(2a8,2i2,i4,1x,f8.3)') 
     &    locus,mentyp,numal, 0, 1, max(0.0,0.01*mappos)
        do 45 i=1,numal
          write(strm,'(5x,i3.3,f8.6)') name(i),alfrq(i)
   45   continue
C Linkage locus file
      elseif (fstyle.eq.8) then
        if (numal.eq.0) then
          write(strm,'(a,1x,a10/a)') 
     &      '3     2  #',locus, '    0.5    0.5'
        else
          call precis(numal,alfrq,4)
          write(strm,'(i1,1x,i5,1x,a1,1x,a10)') 3,numal,'#',locus
          write(strm,'(100(1x,f6.4):)') (alfrq(i),i=1,numal)
        end if
C PAP popln.dat file
      elseif (fstyle.eq.9) then
        nlines=(numal+4)/5
        write(strm,'(i4,a,a10)') nlines,' F F # ',locus
        write(strm,'(i3,5(d15.7))') numal,(alfrq(i),i=1,numal)
      end if
      return
      end
C end-of-wrfreq
C
C remove rounding errors in allele frequencies printed out to precision ndec
C from f3.1 to f9.7
C
      subroutine precis(numal,alfrq,ndec)
      integer MAXALL
      parameter (MAXALL=60)
      integer ndec
C allele frequencies structure
      integer numal
      double precision alfrq(MAXALL)
C topall is most common allele, and the one where we add our correction
      integer i, topall
      character*1 ch
      character*6 fdec
      character*10 buff
      double precision rounded, topfrq, tot

C set print format
      fdec='(f0.0)'
      write(ch,'(i1)') ndec+2
      fdec(3:3)=ch
      write(ch,'(i1)') ndec
      fdec(5:5)=ch
C rewrite to given precision, and calculate accumulated error
      topall=1
      topfrq=0.0d0
      tot=0.0d0
      do 10 i=1,numal
        write(buff,fdec) alfrq(i)
        read(buff,fdec) rounded
        alfrq(i)=rounded
        if (rounded.gt.topfrq) then
          topfrq=rounded
          topall=i
        end if
        tot=tot+rounded
   10 continue
      alfrq(topall)=alfrq(topall)+1.0d0-tot
      return
      end
C end-of-precis
C
C Identify the most common allele
      integer function topall(numal,name,alfrq)
      integer MAXALL
      parameter (MAXALL=60)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
      integer i
      double precision top
      top=0.0d0
      topall=0
      do 10 i=1,numal
      if (alfrq(i).gt.top) then
        top=alfrq(i)
        topall=name(i)
      end if
   10 continue
      return
      end
C end-of-topall
C
C Monte-Carlo test for HWE
C
      subroutine dohwe(wrk,wrk2,locnam,gene,iter,mincnt,hwefnd,
     2             pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3             numloc,  numal, name, cumfrq, set, untyped, 
     4             ngcount,gcount,plevel)
      integer MAXALL, MAXG, MAXSIZ, MAXLOC, KNOWN
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2, 
     &          MAXSIZ=1000, MAXLOC=120, KNOWN=0)
      integer gene,iter,mincnt,plevel,wrk,wrk2
      logical hwefnd
      character*10 locnam
C pedigree structure
      character*10 pedigree
      integer sex(MAXSIZ)
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), set(MAXSIZ,2)
      real locus(MAXSIZ,MAXLOC)
      logical untyped(MAXSIZ)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision cumfrq(MAXALL)
C Genotype counts: allele1,allele2, genotype count, 
C                  ith allele count
      integer ngcount,gcount(MAXG,4)
C
      integer df, g1, g2, gen2, i, it, j, k, tailp, tot
      double precision asyp, chisq, expf, invden, ochisq, mchisq, 
     &  pval, vchisq
      character*3 histo
      character*7 gtp
      logical last
C functions 
      integer getnam
      real random
      double precision chip, ftdev, hwechi
C
      gen2=gene+1
      ngcount=0
      do 1 j=1,numal
      do 1 k=j,numal
        ngcount=ngcount+1
        gcount(ngcount,1)=j
        gcount(ngcount,2)=k
        gcount(ngcount,3)=0
        gcount(ngcount,4)=0
    1 continue
      it=0
      tot=0
      last=.false.
      rewind(wrk)
C
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20

       if (actset.le.0) goto 10
C
         do 12 i=1,nfound
         if (locus(i,gene).lt.KNOWN) then
           untyped(i)=.true.
         else
           tot=tot+1
           untyped(i)=.false.
           g1=getnam(locus(i,gene),numal,name)
           g2=getnam(locus(i,gen2),numal,name)
           call tabgen(g1,g2,ngcount,gcount)
         end if
   12    continue
         if (.not.hwefnd) then
           do 13 i=nfound+1,num
           if (locus(i,gene).lt.KNOWN) then
             untyped(i)=.true.
           else
             tot=tot+1
             untyped(i)=.false.
             g1=getnam(locus(i,gene),numal,name)
             g2=getnam(locus(i,gen2),numal,name)
             call tabgen(g1,g2,ngcount,gcount)
           end if
   13      continue
           write(wrk2) num,nfound, (fa(i),mo(i),untyped(i),i=1,num)
        end if
      goto 10
   20 continue

      ochisq=hwechi(ngcount,gcount,tot)
      df=ngcount-numal

      if (plevel.gt.0) then
        write(*,'(/3a/a/a)') 
     2   '  -------- Observed Genotypes at "',locnam,'" --------',
     3   '       Genotype          Observed    Expected  Deviate',
     4   '  ----------------------------------------------------'
        invden=0.25d0/dfloat(tot)
        do 25 i=1,ngcount
          call wrgtp(name(gcount(i,1)),name(gcount(i,2)),gtp,1)
          expf=dfloat(gcount(gcount(i,1),4)*gcount(gcount(i,2),4)) *
     &         invden
          if (gcount(i,1).ne.gcount(i,2)) expf=expf+expf
          write(*,'(8x,a7,3x,i8,a,f5.3,a,f10.1,1x,f8.1)') 
     2      gtp, gcount(i,3), ' (',dfloat(gcount(i,3))/dfloat(tot),') ',
     3      expf, ftdev(dfloat(gcount(i,3)),expf)
   25   continue
        write(*,'(a/10x,a,3x,i8,a)') 
     2   '  ----------------------------------------------------',
     3   'Total', tot,' (1.000)'
        write(*,'(/a,i4/a,f6.1/a,i4/a,3x,f6.4)')
     2  '       Number of genotypes =',tot,
     3  '  Hardy-Weinberg LR chi-sq =',ochisq,
     4  'Nominal degrees of freedom =',df,
     5  '           Nominal P-value =',chip(ochisq,df)
      end if  
C
C MC sequential P-value for HWE
C
      if (.not.hwefnd .and. iter.gt.0 .and. ngcount.gt.1) then
        mchisq=0.0d0
        tailp=0
        vchisq=0.0d0
   49   continue
        if (it.eq.iter .or. tailp.eq.mincnt) goto 50
          it=it+1
          ngcount=0
          do 52 j=1,numal
          do 52 k=j,numal
            ngcount=ngcount+1
            gcount(ngcount,1)=j
            gcount(ngcount,2)=k
            gcount(ngcount,3)=0
            gcount(ngcount,4)=0
   52     continue
          rewind(wrk2)
   55     continue
            read(wrk2,end=70) num,nfound, 
     &                        (fa(i),mo(i),untyped(i),i=1,num)
            call simped(num,nfound,fa,mo,cumfrq,set)
            do 65 i=1,num
            if (.not.untyped(i)) then
              call tabgen(set(i,1),set(i,2),ngcount,gcount)
            endif
   65       continue
          goto 55
   70     continue
          chisq=hwechi(ngcount,gcount,tot)
          call moment(it,chisq,mchisq,vchisq)
          if (chisq.gt.ochisq .or. (chisq.eq.ochisq .and.
     2        random().gt.0.5))  then
            tailp=tailp+1
          end if
          if (plevel.gt.1) then
            write(*,'(a,i4,a,f6.1)') 
     &        'Pseudosample ',it,': Chisq=',chisq
              if (plevel.gt.2) then
                do 75 j=1,ngcount
	          write(*,*) ' ',gcount(j,1),gcount(j,2),gcount(j,3)
   75           continue
              end if
          end if
          goto 49
   50   continue
        if (tailp.lt.mincnt) then
          tailp=tailp+1
          it=it+1
        end if
        vchisq=vchisq/dfloat(max(1,it-1))
        pval=dfloat(tailp)/dfloat(it)
      else
        tailp=0
        pval=1.0d0
      end if
      if (plevel.gt.0) then
        write(*,'(a,i4,a,i5,a,f6.4,a/a,f6.1,a,f6.1,a)')
     2    '      Equalled or exceeded by =',tailp,'/',it,
     3    ' simulated values (',pval,')',
     4    ' Mean (Var) simulated chi-sqs =',mchisq,' (',vchisq,')'
      else
        asyp=chip(ochisq,df)
        call phist(asyp,pval,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))') 
     2    locnam, tot, ngcount, ochisq, chip(ochisq,df), pval, it, 
     3     'HWE',histo
      end if
      return
      end
C end-of-dohwe
C
C Increment counts of genotypes and alleles for HWE test
C Storage of allele counts in gcount(,4) indexed from 1..nall
C by array index.  By contrast, genotypes indexed by gcount(,1..2).
C
      subroutine tabgen(a1,a2,ngcount,gcount)
      integer MAXALL,MAXG
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2)
      integer a1,a2,ngcount,gcount(MAXG,4)
      integer i,j
C allele counts
      gcount(a1,4)=gcount(a1,4)+1
      gcount(a2,4)=gcount(a2,4)+1
C genotype count, insertion sort to index appropriately
      i=0
    5 continue
        i=i+1
      if (i.le.ngcount .and. (a1.gt.gcount(i,1).or.
     &    (a1.eq.gcount(i,1).and.a2.gt.gcount(i,2)))) goto 5
      if (i.le.ngcount .and. gcount(i,1).eq.a1 .and. gcount(i,2).eq.a2)
     & then
        gcount(i,3)=gcount(i,3)+1
      else
        do 20 j=ngcount,i,-1
        do 20 k=1,3
   20     gcount(j+1,k)=gcount(j,k)
        gcount(i,1)=a1
        gcount(i,2)=a2
        gcount(i,3)=1
        ngcount=ngcount+1
      end if
      return
      end
C end-of-tabgen
C
C Calculate Gibbs chi-square for HWE
C
      double precision function hwechi(ngcount,gcount,tot)
      integer MAXALL, MAXG
      double precision EPS
      parameter(EPS=1.0d-5, MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2)
C allele frequencies and genotype counts
      integer gcount(MAXG,4), ngcount, tot
      integer i
      double precision c,e,o 

      c=0.25d0/dfloat(tot)
      hwechi=0.0d0
      do 30 i=1,ngcount
        o=dfloat(gcount(i,3))
        e=c*dfloat(gcount(gcount(i,1),4)*gcount(gcount(i,2),4))
        if (gcount(i,1).ne.gcount(i,2)) e=e+e
        if (e.gt.EPS .and. o.gt.EPS) then
          hwechi=hwechi+o*log(o/e)
        end if
   30 continue
      hwechi=hwechi+hwechi
      return
      end
C end-of-hwechi
C
C marker homozygosity in all subjects or just probands -- codominant system
C
      subroutine dohomoz(wrk,wrk2,trait,locnam,gene,iter,mincnt,gt,
     2             thresh,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3             numloc,numal,alfrq,cumfrq,untyped,set,plevel)
      integer KNOWN,MAXSIZ,MAXLOC,MAXALL,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MAXALL=60,MISS=-9999)
      integer gene,iter,mincnt,numloc,plevel,trait,wrk,wrk2
      real thresh
      logical gt
      character*10 locnam
C Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), set(MAXSIZ,2)
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      logical last, untyped(MAXSIZ)
C allele frequencies structure
      integer numal
      double precision alfrq(MAXALL), cumfrq(MAXALL)
C 
C homozygosity analysis -- limited to cases
      integer ehomoz, homoz, nca
      integer aff(MAXSIZ),gen2,i,it,tailp
      character*3 histo
      double precision den, ef, expp, fcoeff, obs, pval
C functions
      real isaff, random
      double precision binz

      expp=0.0d0
      gen2=gene+1
      homoz=0
      it=0
      nca=0
      do 5 i=1,numal
        expp=expp+alfrq(i)*alfrq(i)
    5 continue
      last=.false.
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20

       if (actset.le.0) goto 10
C

        if (trait.eq.MISS) then
          do 13 i=1,num
            aff(i)=2
   13     continue
        else
          do 14 i=1,num
            aff(i)=int(isaff(locus(i,trait),thresh,gt))
   14     continue
        end if
        do 15 i=1,num
          untyped(i)=.false.
          set(i,1)=int(locus(i,gene))
          set(i,2)=int(locus(i,gen2))
          if (set(i,1).lt.KNOWN) then
            untyped(i)=.true.
          elseif (aff(i).eq.2) then
            nca=nca+1
            if (set(i,1).eq.set(i,2)) homoz=homoz+1 
          endif
   15   continue
        write(wrk2) num,nfound,
     &      (aff(i),fa(i),mo(i),untyped(i),i=1,num)
      goto 10
   20 continue
        
      if (nca.gt.0) then
        den=1.0d0/dfloat(nca)
        obs=den*dfloat(homoz)
        fcoeff=(obs-expp)/(1.0d0-expp)
      else
        obs=0.0d0
        fcoeff=0.0d0
      end if
C
C if iter=0 or nca=0, Monte-Carlo procedure superfluous
C
      if (iter.gt.0 .and. nca.gt.0) then
C
C Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991
C P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter
C
        tailp=0
   49   continue
        if (it.eq.iter .or. tailp.eq.mincnt) goto 50
          it=it+1
          ehomoz=0
          rewind(wrk2)
   55     continue
            read(wrk2,end=70) num,nfound,
     &        (aff(i),fa(i),mo(i),untyped(i),i=1,num)
            call simped(num,nfound,fa,mo,cumfrq,set)
            do 65 i=1,num
            if (.not.untyped(i) .and. aff(i).eq.2 .and.
     &          set(i,1).eq.set(i,2)) ehomoz=ehomoz+1 
   65       continue
          goto 55
   70     continue
          
          ef=abs((den*dfloat(ehomoz)-expp)/(1.0d0-expp))

          if (ef.gt.abs(fcoeff) .or. (ehomoz.eq.homoz .and.
     2        random().gt.0.5))  then
            tailp=tailp+1
          end if
          if (plevel.gt.1) then
            write(*,'(/a,i4,a,i5)') 
     &        'Pseudosample ',it,': No. homoz=',ehomoz
          end if
          goto 49
   50   continue
        if (tailp.lt.mincnt) then
          tailp=tailp+1
          it=it+1
        end if
        pval=dfloat(tailp)/dfloat(it)
      else
        pval=1.0d0
      end if
      call phist(pval,pval,histo)
      write(*,'(a10,1x,i4,3(1x,f6.4),1x,f6.1,1x,f6.4,1x,i6,2(1x,a))')
     2  locnam, nca, obs, expp, fcoeff, binz(homoz,nca,expp), 
     3   pval, it, 'HOM', histo
      return
      end
C end-of-dohomoz
C
C
C find allele frequency
C
      double precision function getfreq(all,numal,name,alfrq)
      integer MAXALL
      parameter (MAXALL=60)
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
      integer all
      integer i, iall
      iall=abs(all)
      call match(iall,numal,name,i)
      if (i.ne.0) then
        getfreq=alfrq(i)
      else
        write(*,'(a/a,i3,a)') 
     &    'Error in routine getfreq','Looking for ',iall,' in:'
        do 99 i=1,numal
   99     write(*,*) name(i), alfrq(i)
        getfreq=0.0d0
      end if
      return
      end
C end-of-getfreq
C
C find index for allele
C
      integer function getnam(rall,numal,name)
      integer MAXALL,MISS
      parameter (MAXALL=60, MISS=-9999)
      integer numal, name(MAXALL)
      real rall
      integer i,iall

      getnam=MISS
      if (rall.eq.MISS) return

      iall=int(abs(rall))
      call match(iall,numal,name,i)
      if (i.ne.0) then
        getnam=i
      else
        write(*,'(a/a,i3,a)') 
     &    'Error in routine getnam', 'Looking for ',iall,' in:'
        do 99 i=1,numal
          write(*,*) name(i)
   99   continue
      end if
      return
      end
C end-of-getnam
C
C produce cumulative allele frequencies
C
      subroutine accum(numal,alfrq,cumfrq)
      integer MAXALL
      parameter (MAXALL=60)
      integer numal
      double precision alfrq(MAXALL), cumfrq(MAXALL)
      cumfrq(1)=alfrq(1)
      cumfrq(numal)=1.0d0
      do 10 i=2,numal-1
         cumfrq(i)=cumfrq(i-1)+alfrq(i)
   10 continue
      return
      end
C end-of-accum
C
C produce genotype frequencies for Metropolis algorithm
C
      subroutine genot(numal,alfrq,ngtp,gfrq)
      integer MAXALL, MAXG
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2)
C allele frequencies structure
      integer numal, ngtp
      double precision alfrq(MAXALL), gfrq(MAXG)
C local variables
      integer i

      ngtp=0
      do 5 i=1,numal
      do 5 j=1,i
        ngtp=ngtp+1
        gfrq(ngtp)=alfrq(i)*alfrq(j)
    5 continue
      return
      end
C end-of-genot
C
C Do ibs sharing in parents as per Bishop 1990
C
      subroutine domar(wrk,gene,pedigree,actset,num,nfound, 
     2                 id,fa,mo,sex,locus,numloc,
     3                 numal,name,alfrq,plevel)
      integer KNOWN,MAXALL,MAXSIZ,MAXLOC,MISS
      parameter (KNOWN=0,MAXALL=60,MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer gene,actset,num,numloc,plevel,wrk
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C calculate expected ibs statistics for marker
      double precision p, p2, p4, pp, pq, pq2, q, f(3)
C 2 df chi-square
      integer tab(3)
      double precision chisq, ef, expn, mu, obsn
C
      integer currf, currm, g1,g2,g3,g4,gen2,i,ibd,j,nmat
      double precision zibd
      logical last
C functions
      double precision chip

      mu=0.0d0
      do 1 i=1,3
        tab(i)=0
    1 continue
      gen2=gene+1

C Calculate expected values for ibs statistic
      p2=0.0d0
      p4=0.0d0
      pp=0.0d0
      pq2=0.0d0
      do 3 i=1,numal
        p=alfrq(i)
        q=1.0d0-p
        p=p*p
        q=q*q
        pq2=pq2+p*q
        p4=p4+p*p
        do 3 j=i+1,numal
          p=alfrq(i)
          q=alfrq(j)
          p2=p2+p*p*q*q
          pq=1.0d0-p-q
          pp=pp+p*q*pq*pq
    3 continue
      f(1)=pq2+pp+pp
      f(3)=4.0d0*p2+p4
      f(2)=1.0d0-f(3)-f(1)
      ef=f(3)+0.5d0*f(2)
C
      rewind(wrk)
      last=.false.
    5 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20

        if (actset.le.0) goto 5
C 
         currf=MISS
         currm=MISS
         nmat=0
         do 13 i=nfound+1,num
           g1=int(locus(fa(i),gene))
           g3=int(locus(mo(i),gene))
           if ((fa(i).ne.currf .or. mo(i).ne.currm) .and.
     &         g1.gt.KNOWN .and. g3.gt.KNOWN) then
             nmat=nmat+1
             currf=fa(i)
             currm=mo(i)
             g2=int(locus(fa(i),gen2))
             g4=int(locus(mo(i),gen2))
             call share(g1,g2,g3,g4,zibd)
             ibd=int(2.0d0*zibd)+1
             tab(ibd)=tab(ibd)+1
           end if
   13    continue
      goto 5 
   20 continue
      nmat=tab(3)+tab(2)+tab(1)
      if (nmat.gt.0) mu=0.5d0*dfloat(2*tab(3)+tab(2))/dfloat(nmat)
      write(*,'(/a,i4/a,3x,f6.4,a,f6.4,a)')
     2   '   Number of typed matings =',nmat,
     3   ' Parental mean IBS sharing =',  mu, ' (Expected=',ef,')'
      if (nmat.gt.0) then
        chisq=0.0d0
        do 25 i=1,3
          expn=dfloat(nmat)*f(i)
          obsn=dfloat(tab(i))
          if (obsn.gt.0.001d0 .and. expn.gt.0.001d0) then
            chisq=chisq+obsn*log(obsn/expn) 
          end if
   25   continue
        chisq=chisq+chisq
        write(*,'(a,f6.1,a,f6.4,a)')
     &   ' Sharing Chi-square (2 df) =',chisq,' (P=',chip(chisq,2),')' 
      end if
      if (plevel.gt.0) then
        q=1.0d0/dfloat(max(nmat,1))
        write(*,'(2(/21x,a),2(/a,3f8.1))')
     2    'IBS Sharing','2/2     1/2     0/2', 'Observed sharing',
     3    q*dfloat(tab(3)),q*dfloat(tab(2)),q*dfloat(tab(1)),
     4    'Expected sharing', f(3),f(2),f(1) 
      end if
      return
      end
C end-of-domar
C
C Check if multilocus ibs sharing for pairs of sibs is consistent 
C with purported relationship.  Again as per Bishop et al 1990
C
      subroutine ckibs(wrk,wrk2,pedigree,actset,num,nfound,id,fa,mo,sex,
     &              locus, numloc,nloci,loctyp,locpos,numal,name,alfrq)
      integer MAXALL,MAXSIZ,MAXLOC,KNOWN
      parameter (MAXALL=60,MAXSIZ=1000,MAXLOC=120,KNOWN=0)

      integer wrk,wrk2
C Pedigree structure
      integer actset,num, nfound
      character*10 pedigree
      character*8 id(MAXSIZ) 
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer numloc
C
C locus structure
      integer nloci
      integer loctyp(MAXLOC),locpos(MAXLOC)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C expected ibs statistics for each marker
      double precision e2(MAXLOC,2)
      double precision p, p2, p4
C
      integer den,g1,g2,g3,g4,gene,gen2,i,j,k,npairs,sib
      double precision ex, mibs, mean, var, z
      logical last, samefa, samemo
C
      mean=0.0d0
      npairs=0
      var=0.0d0
      pedigree=' '
      last=.false.
      rewind(wrk)
      rewind(wrk2)
C Calculate expected values for ibs=2 statistic
      do 2 k=1,nloci
      if (loctyp(k).eq.1) then
        read(wrk2) numal,(name(i),i=1,numal),(alfrq(i),i=1,numal)
        p2=0.0d0
        p4=0.0d0
        do 3 i=1,numal
          p=alfrq(i)
          p=p*p
          p2=p2+p
          p4=p4+p*p
    3   continue
        e2(k,1)=0.25d0*(1.0d0+2.0d0*p2*(1.0d0+p2)-p4)
        e2(k,2)=0.5d0*(p2*(1.0d0+p2+p2)-p4)
      end if
    2 continue
C
      write(*,'(4(/a))')
     2  '------------------------------------------------------------',
     3  'Estimated Prob(IBS=2) over all markers for sib-pairs',
     4  '------------------------------------------------------------',
     5  'Pedigree    Pers-1   Pers-2    ibs=2     Exp     Dev   Mrkrs'
    5 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20

        if (actset.le.0) goto 5
C
C only iterate nonfounders
        do 10 i=nfound+1,num-1
          do 15 j=i+1,num
            samefa=(fa(i).eq.fa(j))
            samemo=(mo(i).eq.mo(j))
C
C Share a parent
C
            if (samefa.or.samemo) then
              den=0
              ex=0.0d0
              mibs=0.0d0
              if (samefa .and. samemo) then
                sib=1
              else
                sib=2
              end if
              do 30 k=1,nloci
              if (loctyp(k).eq.1) then
                gene=locpos(k)
                g1=int(locus(i,gene))
                g3=int(locus(j,gene))
                if (g1.gt.KNOWN .and. g3.gt.KNOWN) then
                  den=den+1
                  gen2=gene+1
                  g2=int(locus(i,gen2))
                  g4=int(locus(j,gen2))
                  ex=ex+e2(k,sib)
                  if ((g1.eq.g3 .and. g2.eq.g4).or.
     &                (g1.eq.g4 .and. g2.eq.g3)) then
                    mibs=mibs+1.0d0
                  end if
                end if
              end if
   30         continue
              if (den.gt.0) then
                npairs=npairs+1
                z=sqrt(mibs)+sqrt(mibs+1)-sqrt(4*ex+1)
                mibs=mibs/dfloat(den)
                ex=ex/dfloat(den)
                call moment(npairs,mibs,mean,var)
                write(*,'(a,2(a8,1x),2(2x,f6.4),1x,f7.2,2x,i3)') 
     &             pedigree, id(i), id(j), mibs, ex, z, den
              end if
            end if
   15     continue
   10   continue
      goto 5 
   20 continue
      if (npairs.gt.1) var=var/(npairs-1)
      write(*,'(/a,f6.4,a,f6.4,a/)') 
     &  'Grand mean P(ibs=2)=',mean,' (SD=',dsqrt(var),')'
      return
      end
C end-of-ckibs
C
C Calculate observed and expected mean IBS for all pairs of relatives
C Expected distribution simulated using given map
C
      subroutine allibs(wrk,wrk2,iter,nloci,loc,loctyp,locpos,
     2             map,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3             numloc, hset,ibscount,dev,numal,cumfrq,typ,plevel)
      integer IBDSIZ,KNOWN,MAXALL,MAXHAP,MAXIBD,MAXSIZ,MAXLOC,MISS
      parameter(KNOWN=0, MAXALL=60, MAXSIZ=1000, MAXLOC=120,
     2          MAXHAP=MAXLOC/2, MISS=-9999,
     3          MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer iter,plevel,typ,wrk,wrk2
C
C Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer numloc
C
C Locus structure 
      integer nloci
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)
C
C position of locus on sex-averaged linkage map
C
      real map(MAXLOC)
C
C allele and genotype frequencies within entire sample for given locus 
C
      integer numal
      double precision cumfrq(MAXALL)
C
C Storage space for haplotypes
      integer hset(MAXSIZ,MAXHAP,2)
C
C mean ibs sharing for all relative pairs
C
      double precision ibscount(IBDSIZ), dev(IBDSIZ)
C
C Marker list and intermarker distances
      integer nmark, mark(MAXHAP)  
      real recdist(MAXHAP)
C 
      integer gene, gen2, i, j, n, npairs, pos, score
      character*8 fid, mid
      real dist
      double precision crit, den, maxdev
      logical last 
C functions
      real invmap

      dist=0.0
      nmark=0
      do 1 j=1,nloci
      if (loctyp(j).eq.1) then
        nmark=nmark+1
        mark(nmark)=j
        if (map(j).ne.MISS .and. map(j).ge.dist) then
          recdist(nmark)=invmap(map(j)-dist,1)
          dist=map(j)
        else
          recdist(nmark)=0.50
          dist=-1000.0
        end if
        if (nmark.eq.MAXHAP) goto 2
      end if
    1 continue
    2 continue

      den=1.0d0/(dfloat(max(1,iter)))

      write(*,'(4(/a))')
     2  '------------------------------------------------------------',
     3  'IBS sharing outlier pairs contributed by each person',
     4  '------------------------------------------------------------',
     5  'Pedigree   Person   Father   Mother   Max Dev  Outlier Pairs'
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20

        if (actset.le.0 .or. num.gt.MAXIBD) goto 10

        crit=0.95d0
        do 25 i=1,num
        do 25 j=1,nmark
          gene=locpos(mark(j))
          gen2=gene+1
          if (locus(i,gene).gt.KNOWN) then
            hset(i,j,1)=int(locus(i,gene))
            hset(i,j,2)=int(locus(i,gen2))
          else
            hset(i,j,1)=MISS
            hset(i,j,2)=MISS
          end if
   25   continue

        npairs=num*(num-1)/2
        do 90 i=1,npairs
          ibscount(i)=0.0d0
          dev(i)=0.0d0
   90   continue
        
        call allshare(num,ibscount,nmark,hset)
        
        do 100 it=1,iter
          if (plevel.gt.2) write(*,'(/a,i5)') pedigree,it
          call simhap(wrk2,nmark,mark,recdist,numal,cumfrq,
     &                num,nfound,fa,mo,hset,plevel) 
          call expshare(num,ibscount,dev,nmark,hset)
  100   continue
        
        do 105 pos=1,npairs
          dev(pos)=den*dev(pos)
  105   continue
        
        if (typ.eq.1) then
          do 110 i=1,num 
            n=0
            score=0
            maxdev=0.0d0
            pos=(i-2)*(i-1)/2
            do 115 j=1,i-1
              pos=pos+1
              if (ibscount(pos).ne.MISS) then
                n=n+1
                if (abs(dev(pos)).gt.abs(maxdev)) maxdev=dev(pos)
                if (abs(dev(pos)).ge.crit) score=score+1
              end if
  115       continue
            pos=1+(i-1)*i/2
            do 116 j=i+1,num 
              pos=pos+j-2
              if (ibscount(pos).ne.MISS) then
                n=n+1
                if (abs(dev(pos)).gt.abs(maxdev)) maxdev=dev(pos)
                if (abs(dev(pos)).ge.crit) score=score+1
              end if
  116       continue
            if (score.gt.0) then
              fid='x'
              mid='x'
              if (fa(i).ne.MISS) fid=id(fa(i))
              if (mo(i).ne.MISS) mid=id(mo(i))
              write(*,'(a,3(1x,a8),1x,f7.2,1x,i5,a1,i5,1x,5a:)') 
     2         pedigree,id(i),fid,mid,maxdev,score,'/',n,
     3         ('*',j=1,5*score/n)
          end if
  110     continue
        end if
        if (typ.eq.2 .or. plevel.gt.1) then
          if (plevel.gt.1) crit=0.0d0
          write(*,'(//a//a)')
     2      'Estimated Sum(IBS) over all markers for relative pairs',
     3      'Pedigree   Pers-1   Pers-2  Sum(IBS)     Dev'
          pos=0
          do 120 i=2,num 
          do 120 j=1,i-1
            pos=pos+1
            if (ibscount(pos).ne.MISS .and. abs(dev(pos)).ge.crit) then
              write(*,'(a,2(1x,a8),2(1x,f7.2))') 
     &         pedigree, id(i), id(j), ibscount(pos),dev(pos)
            end if
  120     continue
          write(*,*)
        end if

      goto 10
   20 continue
      return
      end
C end-of-allibs 
C
C Simulate haplotypes for all family members for given map
C
      subroutine simhap(wrk2,nmark,mark,recdist,numal,cumfrq,
     &                  num,nfound,fa,mo,hset,plevel) 
      integer KNOWN,MAXALL,MAXHAP,MAXSIZ,MAXLOC,MISS
      parameter(KNOWN=0,MAXALL=60, MAXSIZ=1000,MAXLOC=120,
     &          MAXHAP=MAXLOC/2,MISS=-9999)
      integer plevel, wrk2
C
C Pedigree structure
      integer num, nfound
      integer fa(MAXSIZ), mo(MAXSIZ)
C Marker list and intermarker distances
      integer nmark, mark(MAXHAP)  
      real recdist(MAXHAP)
C
C allele and genotype frequencies within entire sample for given locus 
C
      integer numal
      double precision cumfrq(MAXALL)
C
C Storage space for haplotypes
      integer hset(MAXSIZ,MAXHAP,2)

      integer i,ismiss,j
      logical fin, done(MAXSIZ)
C
C Initialize founders
C
      rewind(wrk2)
      do 30 j=1,nmark 
        read(wrk2) numal,(cumfrq(i),i=1,numal)
        do 31 i=1,nfound
          ismiss=sign(1,hset(i,j,1))
          call found(cumfrq,hset(i,j,1))
          hset(i,j,1)=ismiss*hset(i,j,1)
          call found(cumfrq,hset(i,j,2))
          hset(i,j,2)=ismiss*hset(i,j,2)
   31   continue
   30 continue
      do 32 i=1,nfound
        done(i)=.true.
   32 continue
      do 33 i=nfound+1,num
        done(i)=.false.
   33 continue
C
C then gene drop the nonfounders genotypes
C
   40 continue
        fin=.true.
        do 50 i=nfound+1,num
        if (.not.done(i)) then
          if (done(fa(i)) .and. done(mo(i))) then
            call genof6(i,fa(i),mo(i),nmark,hset,recdist)
            done(i)=.true.
          else
            fin=.false.
          end if
        end if
   50   continue
      if (.not.fin) go to 40

      if (plevel.gt.2) then
        do 100 i=1,num
          write(*,'(i4,100i3:)') i,(hset(i,j,1),j=1,nmark)
          write(*,'(4x,100i3:)')   (hset(i,j,2),j=1,nmark)
  100   continue
      end if
      return
      end
C end-of-simhap
C
C transmit haplotypes from each parent to child, including possibility
C of recombination within haplotype
C 
      subroutine genof6(idx,fa,mo,nmark,hset,recdist)
      integer MAXLOC, MAXSIZ, MAXHAP
      parameter(MAXLOC=120, MAXSIZ=1000, MAXHAP=60)
      integer idx,fa,mo,nmark,hset(MAXSIZ,MAXHAP,2)
      real recdist(MAXHAP)
C local variables
      integer fagranp,mogranp,ismiss,j
C functions
      integer irandom
      real random
C
      fagranp=irandom(1,2)
      mogranp=irandom(1,2)
      do 50 j=1,nmark
        ismiss=sign(1,hset(idx,j,1))
        if (recdist(j).gt.random()) fagranp=3-fagranp
        if (recdist(j).gt.random()) mogranp=3-mogranp
        hset(idx,j,1)=ismiss*abs(hset(fa,j,fagranp))
        hset(idx,j,2)=ismiss*abs(hset(mo,j,mogranp))
   50 continue
      return
      end
C end-of-genof6
C
C Calculate sum of ibs statistics for all markers
C
      subroutine allshare(num,ibscount,nmark,hset)
      integer IBDSIZ, KNOWN, MAXHAP, MAXIBD, MAXSIZ, MAXLOC, MISS
      parameter(KNOWN=0,MAXSIZ=1000,MAXLOC=120, MAXHAP=MAXLOC/2,
     &          MISS=-9999 , MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer nmark, num
C Storage space for haplotypes
      integer hset(MAXSIZ,MAXHAP,2)
C mean ibs sharing for all relative pairs
      double precision ibscount(IBDSIZ)
C local variables
      integer i,j,k,n,pos
      double precision tibs, zibs

      pos=0
      do 10 i=2,num
      do 10 j=1,i-1
        pos=pos+1
        n=0
        tibs=0.0d0
        do 20 k=1,nmark
        if (hset(i,k,1).gt.KNOWN .and. hset(j,k,1).gt.KNOWN) then
          n=n+1
          call share(hset(i,k,1),hset(i,k,2),
     &               hset(j,k,1),hset(j,k,2),zibs)
          tibs=tibs+zibs+zibs
        end if
   20   continue
        if (n.gt.0) then
          ibscount(pos)=tibs
        else
          ibscount(pos)=MISS
        end if
   10 continue
      return
      end
C end-of-allshare
C
C Accumulate null-hypothesis simulated ibs statistics for all markers
C
      subroutine expshare(num,ibscount,dev,nmark,hset)
      integer IBDSIZ, KNOWN, MAXHAP, MAXIBD, MAXSIZ, MAXLOC, MISS
      parameter(KNOWN=0,MAXSIZ=1000,MAXLOC=120, MAXHAP=MAXLOC/2,
     &          MISS=-9999 , MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer nmark, num
C Storage space for haplotypes
      integer hset(MAXSIZ,MAXHAP,2)
C comparison to null hypothesis ibs sharing for all relative pairs
      double precision ibscount(IBDSIZ), dev(IBDSIZ)
C local variables
      integer i,j,k,pos
      double precision tibs, zibs

      pos=0
      do 10 i=2,num
      do 10 j=1,i-1
        tibs=0.0d0
        pos=pos+1
        if (ibscount(pos).ne.MISS) then
          do 20 k=1,nmark
          if (hset(i,k,1).gt.KNOWN .and. hset(j,k,1).gt.KNOWN) then
            call share(hset(i,k,1),hset(i,k,2),
     &                 hset(j,k,1),hset(j,k,2),zibs)
            tibs=tibs+zibs+zibs
          end if
   20     continue
          if (tibs.gt.ibscount(pos) .or. 
     &        (tibs.eq.ibscount(pos) .and. random().gt.0.5)) then
            dev(pos)=dev(pos)+1.0d0
          else
            dev(pos)=dev(pos)-1.0d0
          end if
        end if
   10 continue
      return
      end
C end-of-expshare
