
C
C perform Haseman-Elston sib-pair regression: two-point Cardon & Fulker
C
      subroutine twopair(wrk,trait,mark1,mark2,th1,th2,th12,
     2              pedigree,actset,num,nfound,id, fa, mo, sex, locus, 
     3              numloc,numal,name,alfrq,numal2,name2,alfrq2)
C
C  Pedigree structure
      integer KNOWN, MAXALL, MAXSIZ, MAXLOC, MISS
      parameter(KNOWN=0,MAXALL=60,MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      integer trait,mark1,mark2,wrk
      real th1,th2,th12
C
C allele frequencies within entire sample for given locus 
C
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
      integer numal2, name2(MAXALL)
      double precision alfrq2(MAXALL)
C local variables
      integer contrib,df,hsibs,i,ifail,j,mark12,mark22,sibs
C regression results
      double precision x(4),r(10),b(3),cov(10)
      double precision mux,alpha,sea,beta,seb,tvalb,pi1,pi2
C
      logical last,samefa,samemo
      character*16 error
C functions
      double precision fibd,hibd,pihat, probst
C
      df=0
      ifail=1
      mark12=mark1+1
      mark22=mark2+1
      last=.false.
      hsibs=0
      sibs=0
      mux=0.0d0
      call inicov(4, 10, r)
      rewind(wrk)
    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

        do 10 i=nfound+1,num-1
         contrib=0 
         do 15 j=i+1,num
          samefa=(fa(i).eq.fa(j))
          samemo=(mo(i).eq.mo(j))
C
C Share at least one parent and both trait & marker values present
C
        if (locus(i,trait).ne.MISS .and. locus(j,trait).ne.MISS  .and.
     2      locus(i,mark1).gt.KNOWN .and. locus(j,mark1).gt.KNOWN .and.
     3      locus(i,mark2).gt.KNOWN .and. locus(j,mark2).gt.KNOWN .and.
     4      (samefa.or.samemo))  then
C full or half sibs
          if (contrib.eq.0) contrib=1
          sibs=sibs+1
          x(1)=1.0d0
          x(4)=dble(locus(i,trait)-locus(j,trait))**2
          if (samefa.and.samemo) then
C full sib
            pi1=fibd(locus(i,mark1),locus(i,mark12),
     2               locus(j,mark1),locus(j,mark12),
     3               locus(fa(i),mark1),locus(fa(i),mark12),
     4               locus(mo(i),mark1),locus(mo(i),mark12),
     5               numal,name,alfrq )
            pi2=fibd(locus(i,mark2),locus(i,mark22),
     2               locus(j,mark2),locus(j,mark22),
     3               locus(fa(i),mark2),locus(fa(i),mark22),
     4               locus(mo(i),mark2),locus(mo(i),mark22),
     5               numal2,name2,alfrq2 )
            x(2)=0.0d0
            x(3)=pihat(1,th1, th2, th12, pi1, pi2)
          else
C half sib
            hsibs=hsibs+1
            x(2)=1.0d0
            if (samefa) then
              pi1=hibd(locus(i,mark1),locus(i,mark12),
     2                 locus(j,mark1),locus(j,mark12),
     3                 locus(mo(i),mark1),locus(mo(i),mark12),
     4                 locus(fa(i),mark1),locus(fa(i),mark12),
     5                 locus(mo(j),mark1),locus(mo(j),mark12))
              pi2=hibd(locus(i,mark2),locus(i,mark22),
     2                 locus(j,mark2),locus(j,mark22),
     3                 locus(mo(i),mark2),locus(mo(i),mark22),
     4                 locus(fa(i),mark2),locus(fa(i),mark22),
     5                 locus(mo(j),mark2),locus(mo(j),mark22))
              x(3)=pihat(2,th1, th2, th12, pi1, pi2)
            else
              pi1=hibd(locus(i,mark1),locus(i,mark12),
     2                 locus(j,mark1),locus(j,mark12),
     3                 locus(fa(i),mark1),locus(fa(i),mark12),
     4                 locus(mo(i),mark1),locus(mo(i),mark12),
     5                 locus(fa(j),mark1),locus(fa(j),mark12))
              pi2=hibd(locus(i,mark2),locus(i,mark22),
     2                 locus(j,mark2),locus(j,mark22),
     3                 locus(fa(i),mark2),locus(fa(i),mark22),
     4                 locus(mo(i),mark2),locus(mo(i),mark22),
     5                 locus(fa(j),mark2),locus(fa(j),mark22))
              x(3)=pihat(2,th1, th2, th12, pi1, pi2)
            end if
          end if
          mux=mux+x(3)
          call givenc(r, 10, 4, x, 1.0d0, ifail)
        end if              
   15   continue
        df=df+contrib
   10  continue
      goto 5
   20 continue
C 
      mux=mux/dfloat(sibs)
      call alias(r, 10, 4, 1.0d-5, x, ifail)
      call bsub(r, 10, 4, b, 3, ifail)
      call var(r, 10, cov, 10, 4, sibs, 1, ifail)
      alpha=b(1)
      sea=sqrt(cov(1))
      beta=b(3)
      seb=sqrt(cov(6))
      tvalb=beta/seb
      error='                '
      if (ifail.ne.0) error='Regression error'
      df=df-2
      write(*,99) th12,th1,th2,sibs,mux,alpha,beta,
     2            tvalb,probst(tvalb,df,ifail),error,hsibs,
     3            sea, seb, df
   99 format(f5.3,3x,f5.3,2x,f5.3,1x,i4,2x,f5.3,2(3x,f9.3),3x,f6.2,
     2       4x,f5.3,/2x,a16,3x,i4,' (hsibs)',2(' (',f9.3,')'),
     3       '(df=',i4,')')
      return
      end
C end-of-twopair
C
C estimate regression coefficients for E(pi)=intercpt+b1*pi1+b2*pi2
C using Olson 1995
C
      double precision function pihat(typ, th1, th2, th12, pi1, pi2)
      integer typ
      real th1, th2, th12
      double precision pi1, pi2
      double precision a0, b1, b2, psi1, psi2, psi12
      psi1=1.0d0-2.0d0*dble(th1)*(1.0d0-dble(th1))
      psi2=1.0d0-2.0d0*dble(th2)*(1.0d0-dble(th2))
      psi12=1.0d0-2.0d0*dble(th12)*(1.0d0-dble(th12))
      a0=(1.0d0-psi1)*(1.0d0-psi2)/psi12
      b1=-psi2*(1.0d0-psi2)*(1-2.0d0*psi1)/psi12/(1-psi12)
      b2=-psi1*(1.0d0-psi1)*(1-2.0d0*psi2)/psi12/(1-psi12)
      if (typ.eq.2) a0=a0/2.0d0
      pihat=a0+b1*pi1+b2*pi2
      return
      end
C end-of-pihat
C
C Monte-Carlo approach to estimating IBD sharing at a marker
C
      subroutine wribd(wrk,gene,iter,burnin,typ,pedigree,actset,num,
     2              nfound,id,fa,mo,sex,locus, numloc,numal,name,
     3              alfrq,gfrq,untyped,set,set2,sibd,key,
     4              ibdcount, plevel)
      integer IBDSIZ, KNOWN, MAXALL, MAXG, MAXIBD, MAXSIZ, MAXLOC, MISS
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2, MAXSIZ=1000, 
     2          MAXLOC=120, MISS=-9999, KNOWN=0, 
     3          MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer burnin,gene,iter,wrk,plevel,typ
C  Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      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), gfrq(MAXG)
C work arrays for metropolis algorithm
      integer nuntyp
      logical untyped(MAXSIZ)
      integer set(MAXSIZ,2), sibd(MAXSIZ,2), key(2*MAXSIZ)
C metropolis work arrays
      integer set2(MAXSIZ,2)
C untyped matings
      integer nummat, cntmat(MAXALL,2)
C ibd sharing
      double precision ibdcount(IBDSIZ)
C local variables
      integer g1,g2,gen2,i,idx,j,nfam
      logical alltyp,last,useful
      real den
      double precision zibd
C functions
      integer getnam

      if (typ.gt.2) then
        den=1.0
      else
        den=1.0/float(2*iter)
      end if
      gen2=gene+1
      last=.false.
      nfam=0
      rewind(wrk)
    5 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 5
C
C test if informative pedigree -- at least one relative pair with
C marker genotype for both members
C
        useful=.false.
        do 7 i=1,num
        if (locus(i,gene).gt.KNOWN) then
          do 8 j=max(nfound+1,i+1),num
          if (locus(j,gene).gt.KNOWN) then
            useful=.true.
            goto 9
          end if
    8     continue
        end if
    7   continue
    9   continue
C
        if (.not.useful) goto 5
C
C Load genotypes into set()
        nfam=nfam+1
        nuntyp=0
        alltyp=.true.
        do 12 i=1,num
          if (locus(i,gene).le.KNOWN) then
            alltyp=.false.
            untyped(i)=.true.
            nuntyp=nuntyp+1
            if (locus(i,gene).eq.0 .or. locus(i,gene).eq.MISS) then
              g1=MISS
              g2=MISS
            else
              g1=getnam(-locus(i,gene),numal,name)
              g2=getnam(-locus(i,gen2),numal,name)
            end if
          else
            untyped(i)=.false.
            g1=getnam(locus(i,gene),numal,name)
            g2=getnam(locus(i,gen2),numal,name)
          end if
          call update(i,g1,g2,set)
   12   continue
        do 13 idx=1,num*(num-1)/2
          ibdcount(idx)=0.0d0
   13   continue
C
C IBS
C
        if (typ.gt.2) then
          idx=0
          do 15 i=2,num
            do 16 j=1,i-1
              idx=idx+1
              if (untyped(i) .or. untyped(j)) then
                ibdcount(idx)=-1.0d0
              else
                call share(set(i,1),set(i,2),
     &                     set(j,1),set(j,2),zibd)
                ibdcount(idx)=zibd
              end if
   16       continue
   15     continue
C
C IBD: all genotypes known
C
        elseif (alltyp) then
          do 10 it=1,iter
            call simibd(2,pedigree,num,nfound,fa,mo,set,sibd)
            idx=0
            do 25 i=2,num
              do 26 j=1,i-1
                idx=idx+1
                call share(sibd(i,1),sibd(i,2),
     &                     sibd(j,1),sibd(j,2),zibd)
                ibdcount(idx)=ibdcount(idx)+zibd+zibd
   26         continue
   25       continue
   10     continue
        else
C IBD: some untyped markers:
C produce genotype frequencies for Metropolis criterion
C enumerate untyped founder matings
          call genot(numal,alfrq,ngtp,gfrq)
          call tabmat(num,nfound,fa,mo,untyped,nummat,cntmat)
C Metropolis simulation of genotypes
          if (plevel.gt.1) then
            write(*,'(/2a,4(/a,i4))') 
     2        'Metropolis simulation of pedigree ',pedigree,
     3        'Untyped Individuals: ',nuntyp,
     4        'Possible genotypes : ',ngtp,
     5        'UnT x UnT matings  : ',nummat,
     6        'Burn-in (iters)    : ',burnin
          end if
          do 44 it=1,burnin
            call drop(it,pedigree,num,nfound,id,fa,mo,nummat,
     &             cntmat,untyped,numal,gfrq,set,set2,sibd,key,0)
   44     continue
          do 45 it=1,iter
            call drop(it,pedigree,num,nfound,id,fa,mo,nummat,
     &             cntmat,untyped,numal,gfrq,set,set2,sibd,key,plevel)
            call simibd(1,pedigree,num,nfound,fa,mo,set,set2)
            idx=0
            do 65 i=2,num
              do 66 j=1,i-1
                idx=idx+1
                call share(sibd(i,1),sibd(i,2),
     &                     sibd(j,1),sibd(j,2),zibd)
                ibdcount(idx)=ibdcount(idx)+zibd+zibd
   66         continue
   65       continue
   45     continue
        end if
        
        idx=0
        if (mod(typ,2).eq.1) then
          write(*,'(/2a/a8,1x,f5.2)') 'Pedigree ',pedigree,id(1),1.0
          do 70 i=2,num
            write(*,'(a8,1x,50f5.2,(/6x,50f5.2):)') 
     2        id(i), (den*ibdcount(j), j=idx+1,idx+i-1), 1.0
            idx=idx+i-1
   70     continue
        else
          do 80 i=2,num
          do 80 j=1,i-1
            idx=idx+1
            write(*,'(a10,2(1x,a8),1x,f6.3)') 
     &        pedigree, id(i), id(j), den*ibdcount(idx)
   80     continue
        end if
      goto 5
   20 continue
C
      return
      end
C end-of-wribd  
C
C Write kinship coefficients 
C
      subroutine dokin(wrk,typ,pedigree,actset,num,nfound,id,fa,mo,
     &                 sex,locus,numloc,ibdcount)
      integer IBDSIZ,MAXIBD,MAXSIZ,MAXLOC
      parameter (MAXSIZ=1000,MAXLOC=120,MAXIBD=1000, 
     &           IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer nfound,actset,num,numloc,typ,wrk
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Array to contain kinship coefficients
      double precision ibdcount(IBDSIZ)
C
C local variables: gk,gl,hk,hl are parent-pair indices for dominance
      integer gk,gl,hk,hl,i,idx,j,tot
      double precision dom, meanf
      logical last
C functions
      integer clcpos

      meanf=0.0d0
      tot=0
      if (typ.eq.3) then
        write(*,'(3(/a)/2(/a))')
     2   '--------------------------------------------------',
     3   'Individuals with non-zero inbreeding coefficient',
     4   '--------------------------------------------------',
     5   'Pedigree   Person   Father   Mother   F',
     6   '---------- -------- -------- -------- -----'
      else
        write(*,'(3(/a))')
     2   '--------------------------------------------------',
     3   'Coefficient of relationship for all relative pairs',
     4   '--------------------------------------------------'
        if (typ.eq.2) then
          write(*,'(a//a/)') 
     2      'NOTE:  Writing one relative pair per record',
     3      'Pedigree   Person-1 Person-2    R     K'
        end if
      end if

      last=.false.
      rewind(wrk)
    5 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 5
C 
        call kinship(num,nfound,fa,mo,ibdcount)

        if (typ.eq.3) then
          idx=0
          tot=tot+num
          do 70 i=1,num
            idx=idx+i
            if (ibdcount(idx).gt.1.0d0) then
              meanf=meanf+ibdcount(idx)-1.0d0
              write(*,'(a10,3(1x,a8),1x,f5.3)') 
     &          pedigree,id(i),id(fa(i)),id(mo(i)),ibdcount(idx)-1.0d0
            end if
   70     continue
        else  
          idx=0
          if (typ.eq.1) then
            write(*,'(/2a)') 'Pedigree ',pedigree
            do 75 i=1,num
              write(*,'(a5,1x,50f5.2,(/6x,50f5.2):)') 
     2          id(i), (ibdcount(j), j=idx+1,idx+i)
              idx=idx+i
   75       continue
          else
            do 80 i=1,num
            do 80 j=1,i  
              idx=idx+1
              if (i.eq.j) then
                dom=1.0d0
              elseif (i.gt.nfound .and. j.gt.nfound) then
                gk=clcpos(fa(i),fa(j))
                hl=clcpos(mo(i),mo(j))
                gl=clcpos(fa(i),mo(j))
                hk=clcpos(mo(i),fa(j))
                dom=ibdcount(gk)*ibdcount(hl)+ibdcount(gl)*ibdcount(hk)
                dom=0.25d0*dom
              else
                dom=0.0d0
              end if
              write(*,'(a10,2(1x,a8),1x,f5.3,1x,f5.3)') 
     &          pedigree, id(i), id(j), ibdcount(idx), dom
   80       continue
          end if
        end if
      goto 5
   20 continue
      if (typ.eq.3) then
        if (tot.gt.0) meanf=meanf/dfloat(tot)
        write(*,'(/a,1x,f8.6,a,i5,a)') 'Mean inbreeding coefficient = ',
     &    meanf,' (based on ',tot,' individuals)'
      end if   
      return
      end
C end-of-dokin
C
C Calculate kinship coefficient
C
      subroutine kinship(num,nfound,fa,mo,ibdcount)
      integer IBDSIZ, MAXIBD, MAXSIZ
      parameter (MAXSIZ=1000, MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer nfound,num
C Pedigree structure
      integer fa(MAXSIZ),mo(MAXSIZ)
C Array to contain kinship coefficients
      double precision ibdcount(IBDSIZ)
C local variables
      integer i,idx,j,posfa,posmo
C functions
      integer clcpos

      idx=0
      do 50 i=1,nfound
        do 55 j=1,i-1
          idx=idx+1
          ibdcount(idx)=0.0d0
   55   continue
        idx=idx+1
        ibdcount(idx)=1.0d0
   50 continue
      do 60 i=nfound+1, num
        do 65 j=1,i-1
          idx=idx+1
          posfa=clcpos(fa(i),j)
          posmo=clcpos(mo(i),j)
          ibdcount(idx)=0.5d0*(ibdcount(posfa)+ibdcount(posmo))
   65   continue
        idx=idx+1
        posfa=clcpos(fa(i),mo(i))
        ibdcount(idx)=1.0d0+0.5d0*ibdcount(posfa)
   60 continue
      return
      end
C end-of-kinship
C
C Calculate coefficient of fraternity
C
      subroutine frater(num,nfound,fa,mo,kin,dom)
      integer IBDSIZ, MAXIBD, MAXSIZ
      parameter (MAXSIZ=1000, MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer nfound,num
C Pedigree structure
      integer fa(MAXSIZ),mo(MAXSIZ)
C Array to contain domship coefficients
      double precision kin(IBDSIZ), dom(IBDSIZ)
C local variables
      integer i,idx,j,gk,gl,hl,hk
C functions
      integer clcpos

      idx=0
      do 80 i=1,num
      do 80 j=1,i  
        idx=idx+1
        if (i.eq.j) then
          dom(idx)=1.0d0
        elseif (i.gt.nfound .and. j.gt.nfound) then
          gk=clcpos(fa(i),fa(j))
          hl=clcpos(mo(i),mo(j))
          gl=clcpos(fa(i),mo(j))
          hk=clcpos(mo(i),fa(j))
          dom(idx)=0.25d0 * (kin(gk)*kin(hl)+
     &                       kin(gl)*kin(hk))
        else
          dom(idx)=0.0d0
        end if
   80 continue
      return
      end
C end-of-frater
C
C Do ibs sharing ASP analysis as per Lange 1986 and Bishop 1990
C
      subroutine doasp(wrk,trait,locnam,gene,gt,thresh,pedigree,
     2                 actset,num,nfound,id,fa,mo,sex,locus,numloc,
     3                 numal,name,alfrq,ibd,untyped,set,plevel)
      integer IBDSIZ, KNOWN, MAXALL, MAXIBD, MAXSIZ, MAXLOC, MISS
      parameter(MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2, KNOWN=0,
     &          MAXALL=60, MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer gene,actset,num,numloc,plevel,trait,wrk
      real thresh
      logical gt
      character*10 locnam
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 sibship ibd array 
      double precision ibd(IBDSIZ)
C work arrays for nucibd
      integer set(MAXSIZ,2)
      logical untyped(MAXSIZ)
C calculate expected ibs statistics for marker
      double precision p, p2, p4, pp, pq, pq2, q, f(3), h(3)
C 2 df chi-square
      integer tabf(3),tabh(3)
      double precision chif, chih, ef, eh, ex, muf, muh, mux, obs
C
      integer contrib,currf, currm, fin,gen2,i,ibs,j,k,nfs,nhs,pos
      character*3 histo
      double precision ibdp, ibsp, zibd
      logical last
C functions
      integer getnam
      real isaff
      double precision binp, chip

      muf=0.0d0
      muh=0.0d0
      mux=0.0d0
      do 1 i=1,3
        tabf(i)=0
        tabh(i)=0
    1 continue
      gen2=gene+1
      pedigree=' '
      last=.false.
      rewind(wrk)
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
        p2=p2+p
        pq2=pq2+p*q
        p4=p4+p*p
        do 3 j=i+1,numal
          p=alfrq(i)
          q=alfrq(j)
          pq=1.0d0-p-q
          pp=pp+p*q*pq*pq
    3 continue
      f(3)=0.25d0*(1.0d0+2.0d0*p2*(1.0d0+p2)-p4)
      f(1)=0.25d0*(pq2+pp+pp)
      f(2)=1.0d0-f(3)-f(1)
      ef=f(3)+0.5d0*f(2)
      h(3)=0.5d0*(p2*(1.0d0+p2+p2)-p4)
      h(1)=2.0d0*f(1)
      h(2)=1.0d0-h(3)-h(1)
      eh=h(3)+0.5d0*h(2)
C
    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
        do 7 i=1,num
        if (locus(i,gene).gt.KNOWN) then
          untyped(i)=.false.
          set(i,1)=getnam(locus(i,gene),numal,name)
          set(i,2)=getnam(locus(i,gen2),numal,name)
        else  
          untyped(i)=.true.
          set(i,1)=MISS
          set(i,2)=MISS
        end if
    7   continue
        fin=num
        currf=fa(fin)
        currm=mo(fin)
C only iterate nonfounders -- sibship by sibship
        do 90 k=num-1,nfound,-1
          if (fa(k).ne.currf .or. mo(k).ne.currm) then
            contrib=0
            do 92 i=k+1,fin
            if (isaff(locus(i,trait),thresh,gt).eq.2.0 .and.
     &          .not.untyped(i)) then
              contrib=contrib+1
            end if
   92       continue
C
C Skip if no usable individuals in this sibship
C
            if (contrib.gt.0) then

            call nucibd(gene,currf,currm,k+1,fin,set,untyped,ibd,
     &                  numal, name, alfrq)
            pos=0
            do 95 i=k+1,fin
              do 97 j=k+1,i-1
                pos=pos+1
                if (isaff(locus(i,trait),thresh,gt).eq.2.0 .and.
     2              isaff(locus(j,trait),thresh,gt).eq.2.0 .and.
     3              .not.untyped(i) .and. .not.untyped(j))
     4          then
                  sibs=sibs+1
                  call share(set(i,1), set(i,2),
     &                       set(j,1), set(j,2), zibd)
                  ibs=int(2.0d0*zibd)+1
                  mux=mux+ibd(pos)
                  tabf(ibs)=tabf(ibs)+1
                end if
   97         continue
              pos=pos+1
   95       continue
C
C half-sibs related to current sibship -- only scan sibships not yet visited
C stored in different style to full sibs
C
            do 300 i=nfound+1,k
              if (fa(i).eq.currf .or. mo(i).eq.currm .and.
     2            isaff(locus(i,trait),thresh,gt).eq.2.0 .and.
     3            .not.untyped(i)) then
                contrib=contrib+1
                do 302 j=k+1,fin
                if (isaff(locus(j,trait),thresh,gt).eq.2.0 .and.
     &              .not.untyped(j)) then
                  hsibs=hsibs+1
                  call share(set(i,1), set(i,2),
     &                       set(j,1), set(j,2), zibd)
                  ibs=int(2.0d0*zibd)+1
                  tabh(ibs)=tabh(ibs)+1
                end if
  302           continue
              end if
  300       continue

            end if
C Now update to next sibship
            fin=k
            currf=fa(fin)
            currm=mo(fin)
          end if
   90   continue
      goto 5 
   20 continue

      nfs=tabf(3)+tabf(2)+tabf(1)
      nhs=tabh(3)+tabh(2)+tabh(1)
      if (nfs.gt.0) muf=0.5d0*dfloat(2*tabf(3)+tabf(2))/dfloat(nfs)
      if (nhs.gt.0) muh=0.5d0*dfloat(2*tabh(3)+tabh(2))/dfloat(nhs)
      if (plevel.gt.0) then
        write(*,'(3a/)') 
     &    '----------- ASP analysis for "',locnam,'" --------------'
        write(*,'(2(12x,a/),2(a,i6,2x,3i6,6x,f6.4,3x,f6.4/))')
     2              'No. of  IBS Sharing         Mean IBS sharing',
     3              'Pairs   2/2   1/2   0/2         Obs      Exp',
     4    'Full-sibs',nfs,tabf(3),tabf(2),tabf(1), muf, ef,
     5    'Half-sibs',nhs,tabh(3),tabh(2),tabh(1), muh, eh
        write(*,'(2(12x,a/),2(a,8x,3f6.3/))')
     2              'Expectd IBS Sharing',
     3              '        2/2   1/2   0/2  ',
     4    'Full-sibs',f(3),f(2),f(1), 'Half-sibs',h(3),h(2),h(1)
      end if
      if (nfs.gt.0) then
        chif=0.0d0
        do 25 i=1,3
          ex=dfloat(nfs)*f(i)
          obs=dfloat(tabf(i))
          if (obs.gt.0.001d0 .and. ex.gt.0.001d0) then
            chif=chif+obs*log(obs/ex)
          end if
   25   continue
        chif=chif+chif
        ibsp=chip(chif,2)
        ibdp=binp(2.0d0*mux,dfloat(2*nfs)-2.0d0*mux)
        if (plevel.gt.0) then
          write(*,'(a,f6.1,a,f6.4,a/a,f6.4,a,f6.4,a)') 
     2    'Full-Sib Chi-square (2 df) =',chif,' (P=',ibsp,')',
     3    'Mean full-sib IBD sharing  =',mux/dfloat(nfs),
     4    ' (P=',ibdp,')'
          if (muf.lt.ef) then
            write(*,'(/a/)') 
     &        'NOTE:  Full-sib IBS sharing less than expected.'
          end if
        else
          call phist(ibsp,ibdp,histo)
          write(*,'(a10,1x,i6,5(1x,f6.4),2(1x,a))')
     &    locnam, nfs, muf, ef, ibsp, mux/dfloat(nfs), ibdp, 'ASP',histo
        end if
      end if
      if (nhs.gt.0) then
        chih=0.0d0
        do 35 i=1,3
          ex=dfloat(nhs)*h(i)
          obs=dfloat(tabh(i))
          if (obs.gt.0.001d0 .and. ex.gt.0.001d0) then
            chih=chih+obs*log(obs/ex)
          end if
   35   continue
        chih=chih+chih
        ibsp=chip(chih,2)
        if (plevel.gt.0) then
          write(*,'(a,f6.1,a,f6.4,a)') 
     &      'Half-Sib Chi-square (2 df) =',chih,' (P=',ibsp,')'
          if (muh.lt.eh) then
            write(*,'(/a/)') 
     &      'NOTE:  Half-sib IBS sharing less than expected.'
          end if
        end if
      end if
      return
      end
C end-of-doasp
C
C Perform monte-carlo based APM analysis
C
      subroutine doapm(wrk,trait,locnam,gene,typ,iter,burnin,gt,thresh,
     2                 pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3                 numloc,numal,name,alfrq,cumfrq,gfrq,
     4                 set,set2,sibd,key,untyped,plevel)
C
      integer MAXALL, MAXG, MAXSIZ, MAXLOC, MISS, KNOWN
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2, MAXSIZ=1000, 
     &          MAXLOC=120, MISS=-9999, KNOWN=0)
      integer burnin,gene,iter,plevel,trait,typ,wrk
      real thresh
      logical gt
      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)
      integer set(MAXSIZ,2),sibd(MAXSIZ,2)
      logical untyped(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C metropolis work arrays
      integer set2(MAXSIZ,2),key(2*MAXSIZ)
C untyped matings
      integer nummat, cntmat(MAXALL,2)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL), cumfrq(MAXALL), gfrq(MAXG)
C
C list of affected individuals
C storage is affected ID in aff(1...aff), unaffected ID in aff(unaff...MAXSIZ)
C
      integer naff, unaff, aff(MAXSIZ)
C other local variables
      logical alltyp,fin,last
      integer gen2,g1,g2,i,j,k,nt,ut
      character*3 histo
      double precision den
C families containing AA, AU, UU, AA+AU, GPM/WH pairs
      logical pair(5)
C number of families containing AA, AU, UU, or any AA, AU, UU pairs
      integer nfam(4)
C ibd [,1] or ibs [,1-3] based statistics
      double precision wt,z(5,3),oz(5,3),t(5,3),sz(5,3),v(5,3)
      double precision n(5,3), d(5,3), pval(5,3), zsum(5,3)
C functions
      integer eow, getnam
      real isaff
      double precision makewt, simil, ppnd, zp
C
      if (numal.eq.0) then
        return
      end if
      den=dfloat(iter)
      gen2=gene+1
      nt=0
      ut=0
      do 4 j=1,4
        nfam(j)=0
    4 continue
      do 5 j=1,5
      do 5 k=1,3
        zsum(j,k)=0.0d0
        n(j,k)=0.0d0
        d(j,k)=0.0d0
    5 continue

      if (plevel.gt.0) then
        write(*,'(/3a/)') 
     &    '----------- APM analysis for "',locnam,'" --------------'
      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

        if (actset.le.0) goto 10
C
C transfer genotype to set() and record if typed in untyped()
C record affection status in set2(,2)
C
         alltyp=.true.
         nuntyp=0
         do 6 i=1,num
          if (locus(i,gene).le.KNOWN) then
            alltyp=.false.
            untyped(i)=.true.
            nuntyp=nuntyp+1
            if (locus(i,gene).eq.0 .or. locus(i,gene).eq.MISS) then
              if (typ.eq.1) then
                g1=0
                g2=0
              else
                write(*,'(a/7x,a)') 
     2            'ERROR: Starting genotypes were not generated.',
     3            'Imputation must be set to higher than -1.'
                return 
              end if
            else
              g1=getnam(-locus(i,gene),numal,name)
              g2=getnam(-locus(i,gen2),numal,name)
            end if
          else
            untyped(i)=.false.
            g1=getnam(locus(i,gene),numal,name)
            g2=getnam(locus(i,gen2),numal,name)
          end if
          call update(i,g1,g2,set)
          set2(i,2)=int(isaff(locus(i,trait),thresh,gt))
          set2(i,1)=0
    6   continue
C
C store number of offspring in set2(,1)
C
        do 7 i=nfound+1,num
          set2(fa(i),1)=set2(fa(i),1)+1
          set2(mo(i),1)=set2(mo(i),1)+1
    7   continue
C
C trim uninformative persons ie untyped individuals with no offspring
C by setting their affection status to missing -- update their parents
C offspring number (so that end with number of informative offspring)
C
    8   continue
          fin=.true.
          do 9 i=1,num
          if (set2(i,1).eq.0 .and. untyped(i)) then
            fin=.false.
            set2(i,1)=MISS
            set2(i,2)=MISS
            set2(fa(i),1)=set2(fa(i),1)-1
            set2(mo(i),1)=set2(mo(i),1)-1
          end if
    9     continue
        if (.not.fin) goto 8
C
C transfer affection status to list
C
        naff=0
        unaff=MAXSIZ+1
        do 12 i=1,num
        if (.not.untyped(i) .or. typ.eq.2) then
          if (set2(i,2).eq.2) then
            naff=naff+1
            aff(naff)=i
          elseif (set2(i,2).eq.1) then
            unaff=unaff-1
            aff(unaff)=i
          end if
        end if
   12   continue
         unaff=MAXSIZ+1-unaff
C
C check if family appropriate for different (or any) statistics
C
         if ((naff+unaff).lt.2 .or. num.le.3) then
           if (plevel.gt.0) write(*,'(a,a10//a,/)')
     &       'Pedigree ',pedigree, ' Insufficient persons typed'
           goto 10
         end if
         nfam(4)=nfam(4)+1
         pair(1)=.false.
         pair(2)=.false.
         pair(3)=.false.
         pair(4)=.true.
         pair(5)=.false.
         if (naff.gt.1) then
           nfam(1)=nfam(1)+1
           pair(1)=.true.
           pair(5)=.true.
         end if
         if (naff.gt.0 .and. unaff.gt.0) then
           nfam(2)=nfam(2)+1
           pair(2)=.true.
           if (typ.eq.1) pair(5)=.true.
         end if
         if (unaff.gt.1) then
           nfam(3)=nfam(3)+1
           pair(3)=.true.
         end if
         nt=nt+naff
         ut=ut+unaff
C if ibs based statistic
         if (typ.eq.1) then
           call clcibs(naff,unaff,aff,alfrq,set,oz)
           do 11 j=1,5
           do 11 k=1,3
             pval(j,k)=0.0d0
             sz(j,k)=0.0d0
             v(j,k)=0.0d0
   11      continue
C
C generate ibs distribution under null
C
           do 14 i=1, iter
             call simped(num,nfound,fa,mo,cumfrq,set)
             call clcibs(naff,unaff,aff,alfrq,set,z)
C 
C only update statistic if appropriate family
C
             do 13 j=1,5
             if (pair(j)) then
               do 113 k=1,3
                 if (j.ne.2) then
                   if (z(j,k).gt.oz(j,k) .or. (z(j,k).eq.oz(j,k) .and.
     &               random().gt.0.5)) pval(j,k)=pval(j,k)+1.0d0
                 else
                   if (z(j,k).lt.oz(j,k) .or. (z(j,k).eq.oz(j,k) .and.
     &               random().gt.0.5)) pval(j,k)=pval(j,k)+1.0d0
                 end if
                 call moment(i,z(j,k),sz(j,k),v(j,k))
  113          continue
             end if
   13        continue
   14      continue
C
           do 17 j=1,5
           if (pair(j)) then
             do 117 k=1,3
               if (pval(j,k).eq.0.0d0) then
                 pval(j,k)=0.5d0/den
               elseif (pval(j,k).eq.den) then
                 pval(j,k)=1.0d0-0.5d0/den
               else
                 pval(j,k)=pval(j,k)/den
               end if
               zsum(j,k)=zsum(j,k)+ppnd(1.0d0-pval(j,k))
               v(j,k)=v(j,k)/dfloat(max(1,iter-1))
               if (v(j,k).gt.0) then
                 wt=makewt(j,naff,unaff,v(j,k))
                 t(j,k)=(oz(j,k)-sz(j,k))/sqrt(v(j,k))
                 n(j,k)=n(j,k)+wt*(oz(j,k)-sz(j,k))
                 d(j,k)=d(j,k)+wt*wt*v(j,k)
               else
                 t(j,k)=0.0d0
               end if
  117        continue
           else
             t(j,1)=0.0d0
             t(j,2)=0.0d0
             t(j,3)=0.0d0
           end if  
   17      continue
           if (plevel.gt.1) then
             write(*,'(a,a10,a/a,3(/a,4(1x,f10.3),1x,f6.4))')
     2       'Pedigree ',pedigree,
     3       '  E(Z)     Var(Z)         Z          T      MC-P',
     4       'Aff-Aff',
     5       'f(p) = 1        ',sz(1,1),v(1,1),oz(1,1),t(1,1),pval(1,1),
     6       'f(p) = 1/sqrt(p)',sz(1,2),v(1,2),oz(1,2),t(1,2),pval(1,2),
     7       'f(p) = 1/p      ',sz(1,3),v(1,3),oz(1,3),t(1,3),pval(1,3)
             write(*,'(a,3(/a,4(1x,f10.3),1x,f6.4))')
     2       'Aff-UnA',
     3       'f(p) = 1        ',sz(2,1),v(2,1),oz(2,1),t(2,1),pval(2,1),
     4       'f(p) = 1/sqrt(p)',sz(2,2),v(2,2),oz(2,2),t(2,2),pval(2,2),
     5       'f(p) = 1/p      ',sz(2,3),v(2,3),oz(2,3),t(2,3),pval(2,3)
             write(*,'(a,3(/a,4(1x,f10.3),1x,f6.4))')
     2       'Aff-Aff v. Aff-UnA',
     3       'f(p) = 1        ',sz(5,1),v(5,1),oz(5,1),t(5,1),pval(5,1),
     4       'f(p) = 1/sqrt(p)',sz(5,2),v(5,2),oz(5,2),t(5,2),pval(5,2),
     5       'f(p) = 1/p      ',sz(5,3),v(5,3),oz(5,3),t(5,3),pval(5,3)
             write(*,'(a,3(/a,4(1x,f10.3),1x,f6.4))')
     2       'GPM',
     4       'f(p) = 1        ',sz(4,1),v(4,1),oz(4,1),t(4,1),pval(4,1),
     5       'f(p) = 1/sqrt(p)',sz(4,2),v(4,2),oz(4,2),t(4,2),pval(4,2),
     6       'f(p) = 1/p      ',sz(4,3),v(4,3),oz(4,3),t(4,3),pval(4,3)
             write(*,'(/a,10(1x,a)/(10x,10(1x,a)):)') 
     &         'Affecteds:',(id(aff(i))(1:eow(id(aff(i)))),i=1,naff)
             write(*,'(a,10(1x,a)/(10x,10(1x,a)):)') 
     2         'Unaffectd:',(id(aff(i))(1:eow(id(aff(i)))),
     3                       i=MAXSIZ+1-unaff,MAXSIZ)
             write(*,'(/i5,a,i5,a/)') 
     &          naff,' affecteds and ',unaff,' unaffecteds used'
           end if
C else ibd based statistic calculated
        elseif (typ.eq.2) then
           sz(1,1)=0.0d0
           sz(2,1)=0.0d0
           sz(3,1)=0.0d0
           sz(4,1)=0.0d0
           sz(5,1)=0.0d0
           if (alltyp) then
             do 22 i=1,iter
               call simibd(2,pedigree,num,nfound,fa,mo,set,sibd)
               call clcibd(naff,unaff,aff,sibd,z)
               sz(1,1)=sz(1,1)+z(1,1)
               sz(2,1)=sz(2,1)+z(2,1)
               sz(3,1)=sz(3,1)+z(3,1)
               sz(4,1)=sz(4,1)+z(4,1)
               sz(5,1)=sz(5,1)+simil(nfound,naff,aff,sibd,key)
   22        continue
           else
C some untyped markers:
C produce genotype frequencies for Metropolis criterion
C enumerate untyped founder matings
             call genot(numal,alfrq,ngtp,gfrq)
             call tabmat(num,nfound,fa,mo,untyped,nummat,cntmat)
C
C Metropolis simulation of genotypes
C
             if (plevel.gt.2) then
               write(*,'(/2a,4(/a,i4))') 
     2           'Metropolis simulation of pedigree ',pedigree,
     3           'Untyped Individuals: ',nuntyp,
     4           'Possible genotypes : ',ngtp,
     5           'UnT x UnT matings  : ',nummat,
     6           'Burn-in (iters)    : ',burnin
             end if
             do 24 it=1,burnin
               call drop(it,pedigree,num,nfound,id,fa,mo,nummat,
     2                   cntmat,untyped,numal,gfrq,set,set2,sibd,
     3                   key,0)
   24        continue
             do 25 it=1,iter
               call drop(it,pedigree,num,nfound,id,fa,mo,nummat,
     2                   cntmat,untyped,numal,gfrq,set,set2,sibd,
     3                   key,plevel)
               call clcibd(naff,unaff,aff,sibd,z)
               sz(1,1)=sz(1,1)+z(1,1)
               sz(2,1)=sz(2,1)+z(2,1)
               sz(3,1)=sz(3,1)+z(3,1)
               sz(4,1)=sz(4,1)+z(4,1)
               sz(5,1)=sz(5,1)+simil(nfound,naff,aff,sibd,key)
   25        continue
           end if
C
C now take mean statistics over different ibd realizations
C
           oz(1,1)=sz(1,1)/den
           oz(2,1)=sz(2,1)/den
           oz(3,1)=sz(3,1)/den
           oz(4,1)=sz(4,1)/den
           oz(5,1)=sz(5,1)/den
C
C generate ibd distribution under null
C
           do 29 j=1,5
             pval(j,1)=0.0d0
             sz(j,1)=0.0d0
             v(j,1)=0.0d0
   29      continue
           do 30 i=1, iter
             call simibd(1,pedigree,num,nfound,fa,mo,set,sibd)
             call clcibd(naff,unaff,aff,sibd,z)
             z(5,1)=simil(nfound,naff,aff,sibd,key)
             do 130 j=1,5
             if (pair(j)) then
               if (j.ne.2) then
                 if (z(j,1).gt.oz(j,1) .or. (z(j,1).eq.oz(j,1) .and.
     &               random().gt.0.5)) pval(j,1)=pval(j,1)+1.0d0
               else
                 if (z(j,1).lt.oz(j,1) .or. (z(j,1).eq.oz(j,1) .and.
     &               random().gt.0.5)) pval(j,1)=pval(j,1)+1.0d0
               end if
               call moment(i,z(j,1),sz(j,1),v(j,1))
             end if
  130        continue
   30      continue
           do 36 j=1,5
           if (pair(j)) then
             if (pval(j,1).eq.0.0d0) then
               pval(j,1)=0.5d0/den
             elseif (pval(j,1).eq.den) then
               pval(j,1)=1.0d0-0.5d0/den
             else
               pval(j,1)=pval(j,1)/den
             end if
             zsum(j,1)=zsum(j,1)+ppnd(1.0d0-pval(j,1))
             v(j,1)=v(j,1)/dfloat(max(1,iter-1))
             if (v(j,1).gt.0.0d0) then
               t(j,1)=(oz(j,1)-sz(j,1))/sqrt(v(j,1))
               wt=makewt(j,naff,unaff,v(j,1))
               n(j,1)=n(j,1)+wt*(oz(j,1)-sz(j,1))
               d(j,1)=d(j,1)+wt*wt*v(j,1)
             else
               t(j,1)=0.0d0
             end if
           else
             t(j,1)=0.0d0
           end if
   36      continue
           if (plevel.gt.1) then
             write(*,'(a,a10,a,4(/a,4(1x,f10.3),1x,f6.4))')
     2       'Pedigree ',pedigree,
     3       '  E(Z)     Var(Z)         Z          T      MC-P',
     4       'ibd-based Af-Af ',sz(1,1),v(1,1),oz(1,1),t(1,1),pval(1,1),
     5       'ibd-based Af-Un ',sz(2,1),v(2,1),oz(2,1),t(2,1),pval(2,1),
     6       'ibd-based GPM   ',sz(4,1),v(4,1),oz(4,1),t(4,1),pval(4,1),
     7       'Whit-Halp Score ',sz(5,1),v(5,1),oz(5,1),t(5,1),pval(5,1)
             write(*,'(/a,10(1x,a)/(10x,10(1x,a)):)') 
     &         'Affecteds:',(id(aff(i))(1:eow(id(aff(i)))),i=1,naff)
             write(*,'(a,10(1x,a)/(10x,10(1x,a)):)') 
     2         'Unaffectd:',(id(aff(i))(1:eow(id(aff(i)))),
     3                       i=MAXSIZ+1-unaff,MAXSIZ)
             write(*,'(/i5,a,i5,a/)') 
     &          naff,' affecteds and ',unaff,' unaffecteds used'
           end if
        end if
C end of main loop
      goto 10
   20 continue
      if (plevel.gt.0) then
        write(*,'(/a)')
     &    'Overall statistics        T  NFam  Asy-P InvZ-P' 
      end if
      if (typ.eq.1) then
        do 45 j=1,5
        do 45 k=1,3
          if (nfam(min(j,4)).gt.0) then
            zsum(j,k)=zp(zsum(j,k)/sqrt(dfloat(nfam(min(j,4)))))
          end if
          if (d(j,k).gt.0.0d0) then
            t(j,k)=n(j,k)/sqrt(d(j,k))
          else
            t(j,k)=0.0d0
          end if
   45   continue
        if (plevel.gt.0) then
          write(*,'(a,3(/a,1x,f10.3,1x,i5,2(1x,f6.4)))')
     2      'Aff-Aff',
     3      'f(p) = 1        ',t(1,1),nfam(1),zp(t(1,1)),zsum(1,1),
     4      'f(p) = 1/sqrt(p)',t(1,2),nfam(1),zp(t(1,2)),zsum(1,2),
     5      'f(p) = 1/p      ',t(1,3),nfam(1),zp(t(1,3)),zsum(1,3) 
          write(*,'(a,3(/a,1x,f10.3,1x,i5,2(1x,f6.4)))')
     2      'Aff-UnA',
     3      'f(p) = 1        ',t(2,1),nfam(2),zp(-t(2,1)),zsum(2,1),
     4      'f(p) = 1/sqrt(p)',t(2,2),nfam(2),zp(-t(2,2)),zsum(2,2),
     5      'f(p) = 1/p      ',t(2,3),nfam(2),zp(-t(2,3)),zsum(2,3) 
          write(*,'(a,3(/a,1x,f10.3,1x,i5,2(1x,f6.4)))')
     2      'Aff-Aff v. Aff-UnA',
     3      'f(p) = 1        ',t(5,1),nfam(4),zp(t(5,1)),zsum(5,1),
     4      'f(p) = 1/sqrt(p)',t(5,2),nfam(4),zp(t(5,2)),zsum(5,2),
     5      'f(p) = 1/p      ',t(5,3),nfam(4),zp(t(5,3)),zsum(5,3) 
          write(*,'(a,3(/a,1x,f10.3,1x,i5,2(1x,f6.4)))')
     2      'GPM',
     3      'f(p) = 1        ',t(4,1),nfam(4),zp(t(4,1)),zsum(4,1),
     4      'f(p) = 1/sqrt(p)',t(4,2),nfam(4),zp(t(4,2)),zsum(4,2),
     5      'f(p) = 1/p      ',t(4,3),nfam(4),zp(t(4,3)),zsum(4,3) 
          write(*,'(/a,i5,a,i5,a)') 
     &      'Total of ',nt,' affecteds and ',ut,' unaffecteds used.'
        else
          call phist(zp(t(1,2)), zsum(1,2), histo)
          write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     2      locnam,nfam(1),nt,t(1,2),zp(t(1,2)),zsum(1,2),iter,
     3      'APM-IBS',histo
          call phist(zp(t(4,2)), zsum(4,2), histo)
          write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     2      locnam,nfam(4),nt,t(4,2),zp(t(4,2)),zsum(4,2),iter,
     3      'GPM-IBS',histo
        end if
      elseif (typ.eq.2) then
        if (nfam(1).gt.0) then
          zsum(1,1)=zp(zsum(1,1)/sqrt(dfloat(nfam(1))))
          zsum(5,1)=zp(zsum(5,1)/sqrt(dfloat(nfam(1))))
        end if
        if (nfam(2).gt.0) zsum(2,1)=zp(zsum(2,1)/sqrt(dfloat(nfam(2))))
        if (nfam(4).gt.0) zsum(4,1)=zp(zsum(4,1)/sqrt(dfloat(nfam(4))))
        do 50 j=1,5
        if (d(j,1).gt.0.0d0) then
          t(j,1)=n(j,1)/sqrt(d(j,1))
        else
          t(j,1)=0.0d0
        end if
   50   continue

        if (plevel.gt.0) then
          write(*,'(4(/a,1x,f10.3,1x,i5,2(1x,f6.4)))')
     2      'ibd-based Af-Af ',t(1,1),nfam(1),zp(t(1,1)),zsum(1,1),
     3      'ibd-based Af-Un ',t(2,1),nfam(2),zp(-t(2,1)),zsum(2,1),
     4      'ibd-based GPM   ',t(4,1),nfam(4),zp(t(4,1)),zsum(4,1),
     5      'Whit-Halp Score ',t(5,1),nfam(1),zp(t(5,1)),zsum(5,1) 
          write(*,'(/a,i5,a,i5,a)') 
     &      'Total of ',nt,' affecteds and ',ut,' unaffecteds used.'
        else
          call phist(zp(t(1,1)), zsum(1,1), histo)
          write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     2      locnam,nfam(1),nt,t(1,1),zp(t(1,1)),zsum(1,1),iter,
     3      'APM-IBD',histo
          call phist(zp(t(4,1)), zsum(4,1), histo)
          write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     2      locnam,nfam(4),nt,t(4,1),zp(t(4,1)),zsum(4,1),iter,
     3      'GPM-IBD',histo
        end if
      end if
      return
      end
C end-of-doapm
C
C calculate some plausible weights to allow combination of APM statistics
C from different pedigrees
C type=1 pair=AA, 2 AU, 3 UU, 4 GPM, 5 W-H
C
      double precision function makewt(typ,naff,unaff,var)
      integer typ, naff, unaff
      double precision var
      makewt=0.0d0
      if ((typ.eq.1 .or. typ.eq.5) .and. naff.gt.1) then
        makewt=sqrt(dfloat(naff-1))/sqrt(var)
      elseif (typ.eq.3 .and. unaff.gt.1) then
        makewt=sqrt(dfloat(unaff-1))/sqrt(var)
      elseif (typ.eq.2 .and.(naff+unaff).gt.1) then
        makewt=sqrt(dfloat(naff+unaff-1))/sqrt(var)
      elseif (typ.eq.4 .and.(naff+unaff).gt.1) then
        makewt=dfloat(naff+unaff-1)
        makewt=sqrt(0.5d0*makewt*(makewt-1.0d0))/sqrt(var)
      end if
      return
      end
C end-of-makewt
C
C calculate ibs statistic 
C                      
      subroutine clcibs(naff,unaff,aff,alfrq,set,z)
      integer MAXSIZ, MAXALL
      parameter(MAXSIZ=1000, MAXALL=60)
      integer naff,unaff,aff(MAXSIZ),set(MAXSIZ,2)
      double precision alfrq(MAXALL), z(5,3)
      integer i,j,g1,g2,g3,g4,p1,p2
      double precision d1,d2,pr1,pr2
C functions
      double precision delta
      do 5 i=1,5
      do 5 j=1,3
        z(i,j)=0.0d0
    5 continue
C AA statistic
      if (naff.gt.1) then
      do 10 i=1,naff-1
        p1=aff(i)
        g1=set(p1,1)
        g2=set(p1,2)
        pr1=1.0d0/alfrq(g1)
        pr2=1.0d0/alfrq(g2)
        do 10 j=i+1,naff
          p2=aff(j)
C --- the most recent versions of APM exclude parent-offspring pairs
C --- as a method to increase power to detect linkage over association
C           if (fa(p1).ne.p2 .and. mo(p1).ne.p2 .and.
C    &        fa(p2).ne.p1.and.mo(p2).ne.p1) then
C
          g3=set(p2,1)
          g4=set(p2,2)
          d1=delta(g1,g3)+delta(g1,g4)
          d2=delta(g2,g3)+delta(g2,g4)
          z(1,1)=z(1,1)+d1+d2
          z(1,2)=z(1,2)+d1*sqrt(pr1)+d2*sqrt(pr2)
          z(1,3)=z(1,3)+d1*pr1+d2*pr2
   10 continue
      end if
C AU statistic
      if (naff.gt.0 .and. unaff.gt.0) then
      do 20 i=1,naff
        p1=aff(i)
        g1=set(p1,1)
        g2=set(p1,2)
        pr1=1.0d0/alfrq(g1)
        pr2=1.0d0/alfrq(g2)
        do 20 j=MAXSIZ+1-unaff,MAXSIZ
          p2=aff(j)
          g3=set(p2,1)
          g4=set(p2,2)
          d1=delta(g1,g3)+delta(g1,g4)
          d2=delta(g2,g3)+delta(g2,g4)
          z(2,1)=z(2,1)+d1+d2
          z(2,2)=z(2,2)+d1*sqrt(pr1)+d2*sqrt(pr2)
          z(2,3)=z(2,3)+d1*pr1+d2*pr2
   20 continue
      end if
C UU statistic
      if (unaff.gt.1) then
      do 30 i=MAXSIZ+1-unaff,MAXSIZ-1
        p1=aff(i)
        g1=set(p1,1)
        g2=set(p1,2)
        pr1=1.0d0/alfrq(g1)
        pr2=1.0d0/alfrq(g2)
        do 30 j=i+1,MAXSIZ
          p2=aff(j)
          g3=set(p2,1)
          g4=set(p2,2)
          d1=delta(g1,g3)+delta(g1,g4)
          d2=delta(g2,g3)+delta(g2,g4)
          z(3,1)=z(3,1)+d1+d2
          z(3,2)=z(3,2)+d1*sqrt(pr1)+d2*sqrt(pr2)
          z(3,3)=z(3,3)+d1*pr1+d2*pr2
   30 continue
      end if
C Rescale appropriately
      do 40 i=1,3
      do 40 j=1,3
        z(i,j)=0.25d0*z(i,j)
   40 continue
C Combined statistic
      if (naff.gt.1) then
        z(4,1)=z(4,1)+z(1,1)/naff/(naff-1)
        z(4,2)=z(4,2)+z(1,2)/naff/(naff-1)
        z(4,3)=z(4,3)+z(1,3)/naff/(naff-1)
      end if
      if (naff.gt.1 .and. unaff.gt.1) then
        z(5,1)=2.0d0*z(4,1)-z(2,1)/naff/unaff
        z(5,2)=2.0d0*z(4,2)-z(2,2)/naff/unaff
        z(5,3)=2.0d0*z(4,3)-z(2,3)/naff/unaff
        z(4,1)=z(4,1)-z(2,1)/naff/unaff
        z(4,2)=z(4,2)-z(2,2)/naff/unaff
        z(4,3)=z(4,3)-z(2,3)/naff/unaff
      end if
      if (unaff.gt.1) then
        z(4,1)=z(4,1)+z(3,1)/unaff/(unaff-1)
        z(4,2)=z(4,2)+z(3,2)/unaff/(unaff-1)
        z(4,3)=z(4,3)+z(3,3)/unaff/(unaff-1)
      end if
      return
      end
C end-of-clcibs
C
C measure of IBS sharing 
C
      double precision function delta(g1,g2)
      integer g1, g2
      delta=1.0d0
      if (g1.ne.g2) delta=0.0d0
      return
      end
C end-of-delta
C
C calculate ibd sharing statistic based on simulated ibd
C
      subroutine clcibd(naff,unaff,aff,sibd,zibd)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer naff,unaff,aff(MAXSIZ),sibd(MAXSIZ,2)
      double precision zibd(5,3)
      integer i,j,g1,g2,g3,g4,p1,p2
      double precision ibd

      zibd(1,1)=0.0d0
      zibd(2,1)=0.0d0
      zibd(3,1)=0.0d0
      zibd(4,1)=0.0d0
      zibd(5,1)=0.0d0
C AA statistic
      if (naff.gt.1) then
      do 10 i=1,naff-1
        p1=aff(i)
        g1=sibd(p1,1)
        g2=sibd(p1,2)
        do 10 j=i+1,naff
          p2=aff(j)
          g3=sibd(p2,1)
          g4=sibd(p2,2)
          call share(g1,g2,g3,g4,ibd)
          zibd(1,1)=zibd(1,1)+ibd
   10 continue
      end if
C AU statistic
      if (naff.gt.0 .and. unaff.gt.0) then
      do 20 i=1,naff
        p1=aff(i)
        g1=sibd(p1,1)
        g2=sibd(p1,2)
        do 20 j=MAXSIZ+1-unaff,MAXSIZ
          p2=aff(j)
          g3=sibd(p2,1)
          g4=sibd(p2,2)
          call share(g1,g2,g3,g4,ibd)
          zibd(2,1)=zibd(2,1)+ibd
   20 continue
      end if
C UU statistic
      if (unaff.gt.1) then
      do 30 i=MAXSIZ+1-unaff,MAXSIZ-1
        p1=aff(i)
        g1=sibd(p1,1)
        g2=sibd(p1,2)
        do 30 j=i+1,MAXSIZ
          p2=aff(j)
          g3=sibd(p2,1)
          g4=sibd(p2,2)
          call share(g1,g2,g3,g4,ibd)
          zibd(3,1)=zibd(3,1)+ibd
   30 continue
      end if
C Combined statistic
      if (naff.gt.1) 
     &  zibd(4,1)=zibd(4,1)+zibd(1,1)/naff/(naff-1)
      if (naff.gt.1 .and. unaff.gt.1) 
     &  zibd(4,1)=zibd(4,1)-zibd(2,1)/naff/unaff
      if (unaff.gt.1) 
     &  zibd(4,1)=zibd(4,1)+zibd(3,1)/unaff/(unaff-1)
      return
      end
C end-of-clcibd
C
C return IBD sharing for relative pair based on ibd-alleles
C
      subroutine share(g1,g2,g3,g4,zibd)
      integer g1,g2,g3,g4
      double precision zibd
      if ((g1.eq.g3 .and. g2.eq.g4).or.(g1.eq.g4 .and. g2.eq.g3)) then
        zibd=1.0d0
      elseif (g1.eq.g3 .or. g1.eq.g4 .or. g2.eq.g3 .or. g2.eq.g4) then
        zibd=0.5d0
      else
        zibd=0.0d0
      end if
      return
      end
C end-of-share
C
C Whittemore's & Halpern's (Biometrics 1994; 50:118-127) measure
C of ibd sharing for multiple relatives
C
C for a set of N individuals, enumerate 2**N vectors containing
C one ibd-allele from each person.  For each such set u_i, calculate
C a measure of overall similarity as the number of [additional] "nontrivial"
C permutations of that set that leave u unchanged.  For example, if
C 3 individuals are {1/2} {1/3} {1/2}, there are 8 u's, which give a total
C abc  Legal permutations (excl obs)   of 10 possible permutations, with
C 111  5    acb, bac, bca, cab, cba    a mean of 10/8.  If a 4th relative
C 112  1    bac                        was ibd-genotype {4/5}, the mean
C 131  1    cba                        would be 10/16.  The mean score (S)
C 132  0                               is used to derive a standardized
C 211  1    acb                        score [S-E(S)]/SD(S), as in the APM
C 212  1    cba                        method, although direct enumeration
C 231  0                               is of course feasible for small N.
C 232  1    cba                        
C
C Randomized version
C
      double precision function simil(nfound,naff,aff,sibd,key)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer nfound, naff, aff(MAXSIZ), sibd(MAXSIZ,2)
      integer key(2*MAXSIZ)
      integer i,idx,j,k,tperm
      double precision perm, sum
C functions
      integer irandom
      double precision fact
C
      sum=0.0d0
C
C enumerate all permutations if number of probands (n) < 10
C otherwise sample 1024 random permutations from 2^n
C calls bitwise and, either as and() or iand(), depending on system
C
      if (naff.lt.10) then
        tperm=2**naff
        do 10 i=1,tperm 
          do 15 j=1,2*nfound
            key(j)=0
   15     continue
          k=1
          do 20 j=1,naff
            idx=1

#ifdef F2C
            if (k.eq.and(i,k)) idx=2
#endif F2C
#ifdef HPUX
            if (k.eq.iand(i,k)) idx=2
#endif HPUX
#ifdef DEC
            if (k.eq.iand(i,k)) idx=2
#endif DEC
#ifdef SUN
            if (k.eq.and(i,k)) idx=2
#endif SUN

            k=2*k
            key(sibd(aff(j),idx))=key(sibd(aff(j),idx))+1
   20     continue
          perm=0.0d0
          do 25 j=1,2*nfound
          if (key(j).gt.1) then
            if (perm.eq.0.0d0) then
              perm=fact(key(j))
            else
              perm=perm*fact(key(j))
            end if
          end if
   25     continue
          perm=max(perm-1.0d0,0.0d0)
          sum=sum+perm
   10   continue
      else
        tperm=1024
        do 110 i=1,tperm
          do 115 j=1,2*nfound
            key(j)=0
  115     continue
          do 120 j=1,naff
            idx=irandom(1,2)
            key(sibd(aff(j),idx))=key(sibd(aff(j),idx))+1
  120     continue
          perm=0.0d0
          do 125 j=1,2*nfound
          if (key(j).gt.1) then
            if (perm.eq.0.0d0) then
              perm=fact(key(j))
            else
              perm=perm*fact(key(j))
            end if
          end if
  125     continue
          perm=max(perm-1.0d0,0.0d0)
          sum=sum+perm
  110   continue
      end if
      simil=sum/dfloat(tperm)
      return
      end
C end-of-simil
C 
C update new genotype
C
      subroutine update(idx,all1,all2,set)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer idx, all1, all2
      integer set(MAXSIZ,2)
      if (all1.gt.all2) then
        set(idx,2)=all1
        set(idx,1)=all2
      else
        set(idx,1)=all1
        set(idx,2)=all2
      end if
      return
      end
C end-of-update
C
C Count alleles in pair of relatives or spouses
C
      subroutine countall(p1,p2,p3,p4,nallele,nmiss)
      integer MISS
      parameter(MISS=-9999)
      integer nallele, nmiss, p1,p2,p3,p4
      nallele=0
      nmiss=0
      if (p1.eq.MISS) then
        nmiss=1
      else
        nallele=1
      end if
      if (p2.eq.MISS) then
        nmiss=nmiss+1
      elseif (p1.ne.p2) then
        nallele=nallele+1
      end if
      if (p3.eq.MISS) then 
        nmiss=nmiss+1
      elseif ((p1.ne.p3).and.(p2.ne.p3)) then
        nallele=nallele+1
      end if
      if (p4.eq.MISS) then
        nmiss=nmiss+1
      elseif ((p1.ne.p4).and.(p2.ne.p4).and.(p3.ne.p4)) then
        nallele=nallele+1
      end if
      return
      end
C end-of-countall

