C
C perform Haseman-Elston sib-pair regression: univariate
C using squared difference or centred cross-product 
C and ibds estimated from the entire sibship
C if missing parental genotypes 
C
      subroutine sibpair(wrk,wrk2,trait,locnam,gene,type,mche,iter,
     2              mincnt,weight,pedigree,num,nfound,id,fa,mo,sex,
     3              locus,numloc,numal,name,alfrq,cumfrq,ibd,
     4              untyped,set,plevel)
C
      integer KNOWN, MAXALL, MAXG, MAXSIZ, MAXLOC, MISS
      parameter(KNOWN=0, MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2, 
     &          MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer gene,iter,mincnt,plevel,trait,type,weight,wrk,wrk2
      logical mche
      character*10 locnam
C  Pedigree structure
      character*10 pedigree
      integer num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
      double precision cumfrq(MAXALL)
C sibship ibd array 
      double precision ibd(MAXG)
C work arrays for MC iteration
      integer set(MAXSIZ,2)
      logical untyped(MAXSIZ)
C local variables
      integer contrib,df,famdf,gen2,hsibs,i,it,j,k,ped,pos,sibs
      integer currf, currm, fin, nfam, nped, sta, tailp
      logical last, mhs, phs
      character*3 histo
C regression results
      integer afail, bfail, vfail
      double precision x(4),r(10),b(3),cov(10)
      double precision asyp,beta,mub,mux,muy,
     &                 oalpha,obeta,pval,sdb,sea,seb,tvalb,wt
C functions
      integer getnam
      double precision hibd, probst, regwt
C
      gen2=gene+1
C
C Obtain trait mean, sib and half-sib trait correlations
C
      df=0
      hsibs=0
      sibs=0
      muy=0.0d0
      last=.false.
      rewind(wrk)
    5 continue
        call wrkin(wrk,pedigree,num,nfound,id,fa,mo,sex,locus,numloc,
     &             last)
        if (last) goto 10
        do 3 i=1,num
        if (locus(i,trait).ne.MISS) then
          df=df+1
          muy=muy+dble(locus(i,trait))
        end if
    3   continue
      goto 5
   10 continue
      muy=muy/dfloat(df)
C
C Calculate centred cross-products for each pair
C
      df=0
      nfam=0
      nped=0
      sibs=0
      mux=0.0d0
      call inicov(4, 10, r)
      last=.false.
      rewind(wrk)
   50 continue
        call wrkin(wrk,pedigree,num,nfound,id,fa,mo,sex,locus,numloc,
     &             last)
        if (last) goto 200
C
C record if typed in untyped() and write file for MC routine
C
        nped=nped+1
        do 70 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
   70   continue
        write(wrk2) num,nfound,(fa(i),mo(i),untyped(i),i=1,num)
C
C Full sibs
C
        famdf=0
        fin=num
        currf=fa(fin)
        currm=mo(fin)
        do 90 k=num-1,nfound,-1
          if (fa(k).ne.currf .or. mo(k).ne.currm) then
            nfam=nfam+1
            contrib=0
            do 92 i=k+1,fin
            if (locus(i,trait).ne.MISS .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

            df=df+contrib-1
            famdf=famdf+contrib-1
            write(wrk2) currf, currm, k+1, fin, contrib*(contrib-1)/2
            call nucibd(gene,currf,currm,k+1,fin,set,untyped,ibd,
     &                  numal, name, alfrq)
            pos=0
            do 95 i=k+1,fin-1
              do 97 j=i+1,fin
                pos=pos+1
                if (locus(i,trait).ne.MISS .and. 
     2              locus(j,trait).ne.MISS .and.
     3              .not.untyped(i) .and. .not.untyped(j)) 
     4          then
                  sibs=sibs+1
                  wt=regwt(weight,i,j,locus)
                  x(1)=1.0d0
                  x(2)=0.0d0
                  x(3)=ibd(pos)
                  if (type.eq.2) then
                    x(4)=(dble(locus(i,trait))-muy)*
     &                   (dble(locus(j,trait))-muy)
                  else
                    x(4)=dble(locus(i,trait)-locus(j,trait))**2
                  end if
                  mux=mux+x(3)
                  write(wrk2) pos,wt,x(4)
                  call givenc(r, 10, 4, x, wt, afail)
                end if
   97         continue
   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
              phs=(fa(i).eq.currf)
              mhs=(mo(i).eq.currm)
              if ((phs .or. mhs) .and. 
     &            locus(i,trait).ne.MISS .and. .not.untyped(i)) then
                write(wrk2) contrib 
                do 302 j=k+1,fin
                if (locus(j,trait).ne.MISS .and. .not.untyped(j)) then
                  hsibs=hsibs+1
                  wt=regwt(weight,i,j,locus)
                  x(1)=1.0d0
                  x(2)=1.0d0
                  if (type.eq.2) then
                    x(4)=(dble(locus(i,trait))-muy)*
     &                   (dble(locus(j,trait))-muy)
                  else
                    x(4)=dble(locus(i,trait)-locus(j,trait))**2
                  end if
                  if (phs) then
                    x(3)=hibd(float(set(i,1)),float(set(i,2)),
     2                        float(set(j,1)),float(set(j,2)),
     3                        float(set(mo(i),1)),float(set(mo(i),2)),
     4                        float(set(fa(i),1)),float(set(fa(i),2)),
     5                        float(set(mo(j),1)),float(set(mo(j),2)))
                    write(wrk2) i,j,mo(i),fa(i),mo(j),wt,x(4)
                  else
                    x(3)=hibd(float(set(i,1)),float(set(i,2)),
     2                        float(set(j,1)),float(set(j,2)),
     3                        float(set(fa(i),1)),float(set(fa(i),2)),
     4                        float(set(mo(i),1)),float(set(mo(i),2)),
     5                        float(set(fa(j),1)),float(set(fa(j),2)))
                    write(wrk2) i,j,fa(i),mo(i),fa(j),wt,x(4)
                  end if
                  call givenc(r, 10, 4, x, wt, afail)
                end if
  302           continue
              end if
  300       continue
C mark last halfsib pair
            write(wrk2) 0

            end if
C Now update to next sibship
            fin=k
            currf=fa(fin)
            currm=mo(fin)
          end if
   90   continue
C mark end of sibships in current pedigree
        write(wrk2) MISS, MISS, MISS, MISS, MISS
      goto 50
  200 continue

      if (df.gt.0) then
        mux=mux/dfloat(sibs)
        call alias(r, 10, 4, 1.0d-15, x, afail)
        call bsub(r, 10, 4, b, 3, bfail)
        call var(r, 10, cov, 10, 4, sibs, 1, vfail)
        oalpha=b(1)
        sea=sqrt(cov(1))
        obeta=b(3)
        seb=sqrt(cov(6))
        tvalb=obeta/seb
        if (afail.gt.0 .or. bfail.gt.0 .or. vfail.gt.0) then
          write(*,'(/a,3(/7x,a,i3))') 
     2      'ERROR: Problem in regression (AS164) subroutines.',
     3             'Aliasing Ifail=',afail,
     4             'Backsub  Ifail=',bfail,
     5             'Variance Ifail=',vfail 
        end if
        df=df-2
        if (type.eq.2) then
          asyp=1.0d0-probst(tvalb,df,afail)
        else
          asyp=probst(tvalb,df,afail)
        end if
      else
        mux=0.0d0
        oalpha=0.0d0
        sea=0.0d0
        obeta=0.0d0
        seb=0.0d0
        tvalb=0.0d0
        df=0
        asyp=1.0d0
      end if
C
C MC P-value estimation
C
      it=0
      tailp=0
      mub=0.0d0
      sdb=0.0d0
      if (.not.mche .or. iter.eq.0 .or. df.lt.1) then
        pval=1.0d0
      else
C
C Now can simulate genotypes and do sequential P-value simulation
C
  299   continue
        if (it.eq.iter .or. tailp.eq. mincnt) goto 400
          it=it+1
          call inicov(4, 10, r)
          rewind(wrk2)
          do 330 ped=1,nped
            read(wrk2) num,nfound,(fa(i),mo(i),untyped(i),i=1,num)
            call simped(num,nfound,fa,mo,cumfrq,set)
            do 335 i=1,num
            if (untyped(i)) then
              set(i,1)=MISS
              set(i,2)=MISS
            end if
  335       continue
C     
C read list of sibships -- last one is labelled as missing parents
C     
  500       continue
              read(wrk2) currf, currm, sta, fin, npairs
        
            if (currf.eq.MISS) goto 501
        
              call nucibd(gene,currf,currm,sta,fin,set,untyped,ibd,
     &                    numal, name, alfrq)
              do 310 k=1,npairs
                read(wrk2) pos,wt,x(4)
                x(1)=1.0d0
                x(2)=0.0d0
                x(3)=ibd(pos)
                call givenc(r, 10, 4, x, wt, afail)
  310         continue
C     
C list of half-sib pairs follows each sibship
C     
  503         continue
                read(wrk2) npairs
              if (npairs.le.0) goto 504
                do 311 k=1,npairs
                  read(wrk2) i,j,currf,commp,currm,wt,x(4)
                  x(1)=1.0d0
                  x(2)=1.0d0
                  x(3)=hibd(float(set(i,1)),float(set(i,2)),
     2                      float(set(j,1)),float(set(j,2)),
     3                      float(set(currf,1)),float(set(currf,2)),
     4                      float(set(commp,1)),float(set(commp,2)),
     5                      float(set(currm,1)),float(set(currm,2)))
                  call givenc(r, 10, 4, x, wt, afail)
  311           continue
              goto 503
  504         continue
                
            goto 500
  501       continue
        
  330     continue
          call alias(r, 10, 4, 1.0d-15, x, afail)
          call bsub(r, 10, 4, b, 3, bfail)
          beta=b(3)
          call moment(it,beta,mub,sdb)
          if ((type.eq.1 .and. beta.lt.obeta) .or. 
     2        (type.eq.2 .and. beta.gt.obeta) .or. 
     3        (beta.eq.obeta .and. random().gt.0.5d0)) 
     4    then
            tailp=tailp+1
          end if
          if (plevel.gt.1) then
            write(*,'(a,i4,a,f12.4,a,2i3)') 
     &        'Pseudosample ',it,': Beta=', beta, ' Ifail=',afail, bfail
          end if
        
          goto 299
  400   continue
        if (tailp.lt.mincnt) then
          tailp=tailp+1
          it=it+1
        end if
        sdb=sqrt(sdb/dfloat(max(1,it-1)))
        pval=dfloat(tailp)/dfloat(it)
      end if
      if (plevel.gt.0) then
        write(*,'(/a,i5,a,i5,a/a,i5/a,f5.3)') 
     2    'No. full-sib pairs = ',sibs, ' (in ',nfam,' sibships)',
     2    'No. half-sib pairs = ',hsibs,
     3    'Mean full-sib ibd  = ',mux
        write(*,'(a,f10.4,a,f10.4,a/a,f10.4,a,f10.4,a)')
     2    'Intercept (f-s)    = ',oalpha,' (ase=',sea,')',
     3    'Slope              = ',obeta, ' (ase=',seb,')'
        write(*,'(a,f10.4,a,i3,a,f6.4,a)')
     2    't value            = ',tvalb,' (df=',df,
     3    ', P=', asyp ,')' 
        write(*,'(/a,i4,a,i5,a,f6.4,a/a,f12.4,a,f12.4,a)')
     2    'Equalled or exceeded by =',tailp,'/',it,
     3    ' simulated values (',pval,')',
     4    'Mean (SD) simulated Beta=',mub,' (',sdb,')'
      else
        call phist(asyp,pval,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     &    locnam, sibs, hsibs, tvalb, asyp, pval, it, 'H-E',histo
      end if
      return
      end
C end-of-sibpair
C
C Routines to calculate ibd sharing using full sibship information
C where parent(s) untyped.
C
C ibd(1..nsib*(nsib-1)/2)
C prall(5) probs for 1..4 observed alleles plus all others
C
C 1. enumerate alleles segregating among children
C 2. generate short list of genotypes for parents
C 3. sum up ibd sharing for each pair of sibs for each genotype freq
C 
      subroutine nucibd(gene,cfa,cmo,sta,fin,set,untyped,ibd,
     &                  numal, name, alfrq)

      integer KNOWN,MAXALL,MAXG,MAXLOC,MAXSIZ,MISS
      parameter (KNOWN=0,MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,
     &           MAXLOC=120,MAXSIZ=1000,MISS=-9999)
      integer gene
C Pedigree structure
      integer cfa, cmo, fin, sta, set(MAXSIZ,2)  
      logical untyped(MAXSIZ)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C
      double precision ibd(MAXG)
C
C count of segregating alleles, and frequency
      integer nall, allele(5)
      double precision prall(5)
C other local variables
      integer g1,g2,g3,g4
      integer gen2,i,j,npairs,mg1,mg2,pg1,pg2,pos
      integer i1,i2,t1,t2
      double precision lik
C functions
      integer parcon, whall
      double precision shibd

      gen2=gene+1
      pos=0

      ptyped=0
      if (.not.untyped(cfa)) then
        ptyped=ptyped+1
        pg1=set(cfa,1)
        pg2=set(cfa,2)
      end if
      if (.not.untyped(cmo)) then
        ptyped=ptyped+2
        mg1=set(cmo,1)
        mg2=set(cmo,2)
      end if

      if (ptyped.eq.3) then
        do 120 i=sta, fin-1
        do 120 j=i+1, fin
          pos=pos+1
          ibd(pos)=shibd(set(i,1),set(i,2),set(j,1),set(j,2),
     &                   pg1, pg2, mg1, mg2)
  120   continue
        return
      end if
C
C else sum over all possible parental genotypes
C
      nall=0
      if (ptyped.eq.1) then
        call addall(pg1,nall,allele)
        call addall(pg2,nall,allele)
      elseif (ptyped.eq.2) then
        call addall(mg1,nall,allele)
        call addall(mg2,nall,allele)
      end if
      do 1 i=sta, fin
      if (.not.untyped(i)) then
        call addall(set(i,1),nall,allele)
        call addall(set(i,2),nall,allele)
      end if
    1 continue

      npairs=(fin-sta+1)*(fin-sta)/2
C first check
      if (nall.gt.4) then
        write(*,'(a)') 'ERROR:  Mendelian inconsistency detected.'
        do 3 pos=1,npairs
          ibd(pos)=0.5d0
    3   continue
        return
      end if
C else continue
      do 4 pos=1,npairs
        ibd(pos)=0.0d0
    4 continue
      nall=nall+1
      allele(nall)=0 
      prall(nall)=1.0d0
      do 2 i=1,nall-1
        prall(i)=alfrq(allele(i))
        prall(nall)=prall(nall)-prall(i)
    2 continue
C
C While loop to list all possible genotypes
C initialize genotype indices
C
      if (ptyped.eq.1) then
        t1=1
        i1=1
        g1=whall(pg1,nall,allele)
        g2=whall(pg2,nall,allele)
      else
        t1=nall*(nall+1)/2
        i1=0
        g1=1
        g2=0
      end if
      if (ptyped.eq.2) then
        t2=1
        i2=1
        g3=whall(mg1,nall,allele)
        g4=whall(mg2,nall,allele)
      else
        t2=nall*(nall+1)/2
        i2=t2
        g3=1
        g4=0
      end if
C
C simulated nested do-loops
C check if inner loop completed once
C
      totp=0.0d0

  100 continue
        if (i2.eq.t2) then
          call couple(i1,t1,nall,g1,g2)
          pg1=allele(g1)
          pg2=allele(g2)
          if (t2.gt.1) i2=0
        end if
        call couple(i2,t2,nall,g3,g4)
        mg1=allele(g3)
        mg2=allele(g4)
        do 10 i=sta,fin
        if (.not.untyped(i) .and. 
     &      parcon(set(i,1),set(i,2),pg1,pg2,mg1,mg2).eq.0) then
          goto 55
        end if
   10   continue
C
C else (if consistent) calculate likelihood
C
C L = Pr(G) = Pr(Children & Parents) = Pr(P) Pr(C|P) 
C   = Prod{ Pr(P_j) } Prod { Pr(C_i | Father_i Mother_i }
C
        lik=prall(g1)*prall(g2)*prall(g3)*prall(g4)
        if (g1.ne.g2) lik=lik+lik
        if (g3.ne.g4) lik=lik+lik
        do 15 i=sta,fin
        if (.not.untyped(i)) then
          lik=lik*0.25d0*
     &        dfloat(parcon(set(i,1),set(i,2),pg1,pg2,mg1,mg2))
        end if
   15   continue

        totp=totp+lik
C
        pos=0
        do 20 i=sta, fin-1
        do 20 j=i+1, fin
          pos=pos+1
          ibd(pos)=ibd(pos)+
     2             lik*shibd(set(i,1),set(i,2),set(j,1),set(j,2),
     3                       pg1,pg2,mg1,mg2)
   20   continue
   55   continue
C end of while loop
      if (i1.ne.t1 .or. i2.ne.t2) goto 100
C abort if error else rescale likelihood
      if (totp.eq.0.0d0) then
        write(*,'(a)') 'ERROR:  Mendelian inconsistency detected.'
        do 32 pos=1,npairs
          ibd(pos)=0.5d0
   32   continue
      else
        totp=1.0d0/totp
        do 33 pos=1,npairs
          ibd(pos)=min(1.0d0,totp*ibd(pos))
   33   continue
      end if
      return
      end
C end-of-nucibd
C
C Enumerate all combinations of i ~ I(1..range) with itself
C If index=tot then return last tuple
C
      subroutine couple(idx,tot,range,i1,i2)
      integer idx,i1,i2,range,tot

      if (idx.eq.tot) return

      idx=idx+1
      i2=i2+1
      if (i2.gt.range) then
        i1=i1+1
        if (i1.gt.range) i1=1
        i2=i1
      end if
      return
      end
C end-of-couple
C
C Find index of allele segregating in nuclear family
C
      integer function whall(iall,nall,allele)
      integer iall, nall, allele(5)
      integer i
      do 10 i=1,nall-1
      if (iall.eq.allele(i)) then
        whall=i
        return
      end if
   10 continue
      whall=nall
      return
      end
C end-of-whall
C
C Calculate ibd sharing for full sibs when parental genotypes known
C
      double precision function shibd(c11,c12,c21,c22,p11,p12,p21,p22)
      integer KNOWN, MISS
      parameter(KNOWN=0, MISS=-9999)
      integer c11,c12,c21,c22,p11,p12,p21,p22

      logical h1, h2
      integer nallele, nmiss, cnallele
      integer shared
C 
C overall expectation 
      shibd=0.5d0
C
C deal with simplest cases
      call countall(c11,c12,c21,c22,cnallele,nmiss)
      if (cnallele.eq.4 .or.(c11.ne.c21 .and. c11.ne.c22 .and.
     &    c12.ne.c21 .and. c12.ne.c22)) then
        shibd=0.0d0
        return
      end if
      call countall(p11,p12,p21,p22,nallele,nmiss)
C
      h1=.false.
      h2=.false.
      if (p11.ne.p12) h1=.true.
      if (p21.ne.p22) h2=.true.
      shared=MISS
      if (nallele.eq.3 .and. h1 .and. h2) then
        shared=p11
        if (p11.ne.p21 .and. p11.ne.p22) shared=p12
      end if
      if (nallele.eq.4 .or. (nallele.eq.3 .and. h1.and.h2)) then
        if (c11.eq.c21 .and. c12.eq.c22 ) then
          shibd=1.0d0
        elseif (c11.ne.c12 .and. c21.ne.c22 .and.
     3      (((c11.eq.c21.or.c11.eq.c22) .and. c11.eq.shared ) .or.
     4      ((c12.eq.c21.or.c12.eq.c22) .and. c12.eq.shared ))) 
     5  then
          shibd=0.0d0
        end if
      elseif (nallele.eq.3) then
        shibd=0.25d0
        if (c11.eq.c21 .and. c12.eq.c22 ) shibd=0.75d0
      else
        if (h1 .and. h2) then
          if (c11.eq.c21 .and. c12.eq.c22) then
            shibd=1.0d0
            if (c11.ne.c22) shibd=0.5d0
          end if
        elseif (h1 .or. h2) then  
          shibd=0.25d0
          if (c11.eq.c21 .and. c12.eq.c22) shibd=0.75d0
        end if
      end if
      return
      end
C end-of-shibd
C
C Calculate regression weight
C
      double precision function regwt(weight,i,j,locus)
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer i,j,weight
      real locus(MAXSIZ,MAXLOC)
      if (weight.ne.MISS .and. 
     2    locus(i,weight).ne.MISS .and.
     3    locus(j,weight).ne.MISS) then
        regwt=0.5d0*dble(locus(i,weight)+locus(j,weight))
      else
        regwt=1.0d0
      end if
      return
      end
C end-of-regwt
C
C Calculate ibd sharing for full sibs 
C
      double precision function fibd(c11,c12,c21,c22,p11,p12,p21,p22, 
     &                               numal,name,alfrq)
      integer KNOWN, MAXALL, MISS
      parameter(KNOWN=0, MAXALL=60, MISS=-9999)
      integer nallele, nmiss, cnallele, cnmiss
      real c11,c12,c21,c22,p11,p12,p21,p22
      logical h1, h2
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
      integer ic11,ic12,ic21,ic22,ip11,ip12,ip21,ip22,t1,t2
      integer shared, unshared
      double precision pr1, pr2
C functions
      double precision getfreq
C 
C overall expectation 
      fibd=0.5d0
      ic11=MISS
      ic12=MISS
      ic21=MISS
      ic22=MISS
      if (c11.gt.KNOWN) ic11=int(c11)
      if (c12.gt.KNOWN) ic12=int(c12)
      if (c21.gt.KNOWN) ic21=int(c21)
      if (c22.gt.KNOWN) ic22=int(c22)
C
C deal with simplest cases
      call countall(ic11,ic12,ic21,ic22,cnallele,cnmiss)
      if (cnmiss.gt.0) then 
        return
      elseif (cnallele.eq.4 .or.(ic11.ne.ic21 .and. ic11.ne.ic22 .and.
     &        ic12.ne.ic21 .and. ic12.ne.ic22)) then
        fibd=0.0d0
        return
      end if
      ip11=MISS
      ip12=MISS
      ip21=MISS
      ip22=MISS
      if (p11.gt.KNOWN) ip11=int(p11)
      if (p12.gt.KNOWN) ip12=int(p12)
      if (p21.gt.KNOWN) ip21=int(p21)
      if (p22.gt.KNOWN) ip22=int(p22)
      call countall(ip11,ip12,ip21,ip22,nallele,nmiss)
      if (nallele.eq.1.and.nmiss.eq.0) return
C
C deal with all missing parental genotypes
      if (nmiss.eq.4) then
        if (cnallele.eq.1) then
          fibd=1.0d0/(1.0d0+getfreq(ic11,numal,name,alfrq))
        elseif (cnallele.eq.2) then
          if (ic11.eq.ic12) then
            fibd=1.0d0/2.0d0/(1.0d0+getfreq(ic11,numal,name,alfrq))
          elseif (ic21.eq.ic22) then
            fibd=1.0d0/2.0d0/(1.0d0+getfreq(ic21,numal,name,alfrq))
          else
            pr1=getfreq(ic11,numal,name,alfrq)
            pr2=getfreq(ic12,numal,name,alfrq)
            fibd=(2.0d0+pr1+pr2)/2.0d0/(1.0d0+pr1+pr2+2.0d0*pr1*pr2)
          end if
        elseif (cnallele.eq.3) then
          if (ic11.eq.ic21.or.ic11.eq.ic22) then
            fibd=1.0d0/2.0d0/(1.0d0+
     &           2.0d0*getfreq(ic11,numal,name,alfrq))
          else
            fibd=1.0d0/2.0d0/(1.0d0+
     &           2.0d0*getfreq(ic21,numal,name,alfrq))
          end if
        end if
C     write(*,'(a,i1,a,f5.3)') 'nallele=',nallele,' ibd=',fibd
C     write(*,'(a)') 'Child-1   Child-2   Parent-1  Parent-2'
C     write(*,'(8i5)') ic11,ic12,ic21,ic22,ip11,ip12,ip21,ip22
        return
      end if
C
C else do case where only one parent has been typed
C
      if ((ip11.eq.MISS.and.ip12.eq.MISS) .or. 
     &    (ip21.eq.MISS.and.ip22.eq.MISS)) then
        if (ip11.eq.MISS) then
          t1=ip21
          t2=ip22
        else
          t1=ip11
          t2=ip12
        end if
C       write(*,*) 't1,t2=',t1,t2,' cnallele=',cnallele
C       write(*,*) 'freq=',getfreq(ic11,numal,name,alfrq)
        h1=.false.
        if (t1.ne.t2) h1=.true.
        if (cnallele.eq.1) then
          pr1=getfreq(ic11,numal,name,alfrq)
          if (t1.eq.ic11.and..not.h1) then
C --------- fibd=(3.0d0-getfreq(ic11,numal,name,alfrq))/4.0d0
            fibd=(3.0d0+pr1)/(4.0d0+4.0d0*pr1)
          else
            fibd=(2.0d0*pr1+1.0d0)/(3.0d0*pr1+1.0d0)
          end if
        elseif (cnallele.eq.2) then
          if (ic11.eq.ic12) then
C first child is homozygote and second is heterozygote
            unshared=ic21
            if (ic21.eq.ic11) unshared=ic22
            if (.not.h1) then
               fibd=0.25d0
            elseif (t1.eq.unshared .or. t2.eq.unshared) then
               pr1=getfreq(ic11,numal,name,alfrq)
               pr2=getfreq(unshared,numal,name,alfrq)
               fibd=0.5d0*(1.0d0+pr2)/(1+pr1+pr2)
C ------------ fibd=1.0d0/2.0d0/(1.0d0+getfreq(ic11,numal,name,alfrq))
            else
               fibd=1.0d0
            end if
          elseif (ic21.eq.ic22) then
C second child is homozygote and first is heterozygote
            unshared=ic11
            if (ic11.eq.ic21) unshared=ic12
            if (.not.h1) then
               fibd=0.25d0
            elseif (t1.eq.unshared .or. t2.eq.unshared) then
               pr1=getfreq(ic21,numal,name,alfrq)
               pr2=getfreq(unshared,numal,name,alfrq)
               fibd=0.5d0*(1.0d0+pr2)/(1+pr1+pr2)
C ------------ fibd=1.0d0/2.0d0/(1.0d0+getfreq(ic21,numal,name,alfrq))
            else
               fibd=1.0d0
            end if
          else
C 12-12 sibpair
            if (.not.h1) then
              if (t1.eq.ic11) then
                pr1=getfreq(ic12,numal,name,alfrq)
              else
                pr1=getfreq(ic11,numal,name,alfrq)
              end if
              fibd=(3.0d0+pr1)/4.0d0/(1.0d0+pr1)
            elseif (t1.eq.ic11 .and. t2.eq.ic12) then
              pr1=getfreq(ic11,numal,name,alfrq)
              pr2=getfreq(ic12,numal,name,alfrq)
              fibd=0.5d0*(pr1*(2.0d0+pr1)+pr2*(2.0d0+pr2))/(pr1+pr2)/
     &             (1.0d0+pr1+pr2)
C             fibd=((pr1-pr2)**2+2.0d0*(pr1+pr2))/
C    &             2.0d0/(pr1**2+pr1+pr2+pr2**2)
            else
              if (t1.eq.ic11) then
                pr1=getfreq(ic12,numal,name,alfrq)
              else
                pr1=getfreq(ic11,numal,name,alfrq)
              end if
              fibd=(2.0d0+pr1)/2.0d0/(1.0d0+pr1)
            end if
          end if
        elseif (cnallele.eq.3) then
          shared=ic11
          if (ic12.eq.ic21 .or. ic12.eq.ic22) shared=ic12
          if ((t1.eq.ic11.and.t2.eq.ic12) .or.
     &        (t1.eq.ic21.and.t2.eq.ic22)) then
            pr1=getfreq(t1,numal,name,alfrq)
            pr2=getfreq(t2,numal,name,alfrq)
            if (t2.eq.shared) then
              fibd=0.5d0*pr1/(pr1+pr2)
            else
              fibd=0.5d0*pr2/(pr1+pr2)
            end if
          else
            pr1=getfreq(shared,numal,name,alfrq)
            fibd=0.25d0*(2.0d0-pr1)
          end if
        end if
C ---------------------------- Diagnostic Print
C     write(*,'(a,i1,a,f5.3)') 'nallele=',nallele,' ibd=',fibd
C     write(*,'(a)') 'Child-1   Child-2   Parent-1  Parent-2'
C     write(*,'(8i5)') ic11,ic12,ic21,ic22,ip11,ip12,ip21,ip22
C ------------------------ End Diagnostic Print
        return
      end if
C
C proceed to case where all parental genotypes known
      h1=.false.
      h2=.false.
      if (ip11.ne.ip12) h1=.true.
      if (ip21.ne.ip22) h2=.true.
      shared=MISS
      if (nallele.eq.3 .and.h1.and.h2) then
        shared=ip11
        if (ip11.ne.ip21.and.ip11.ne.ip22) shared=ip12
      end if
      if (nallele.eq.4 .or. (nallele.eq.3 .and. h1.and.h2)) then
        if (ic11.eq.ic21 .and. ic12.eq.ic22 ) then
          fibd=1.0d0
        elseif (ic11.ne.ic12 .and. ic21.ne.ic22 .and.
     3      (((ic11.eq.ic21.or.ic11.eq.ic22) .and. ic11.eq.shared ) .or.
     4      ((ic12.eq.ic21.or.ic12.eq.ic22) .and. ic12.eq.shared ))) 
     5  then
          fibd=0.0d0
        end if
      elseif (nallele.eq.3) then
        fibd=0.25d0
        if (ic11.eq.ic21 .and. ic12.eq.ic22 ) fibd=0.75d0
      else
        if (h1 .and. h2) then
          if (ic11.eq.ic21 .and. ic12.eq.ic22) then
            fibd=1.0d0
            if (ic11.ne.ic22) fibd=0.5d0
          end if
        elseif (h1 .or. h2) then  
          fibd=0.25d0
          if (ic11.eq.ic21 .and. ic12.eq.ic22) fibd=0.75d0
        end if
      end if
C------------------------------- Diagnostic Print
C     write(*,'(a,i1,a,f5.3)') 'nallele=',nallele,' ibd=',fibd
C     write(*,'(a)') 'Child-1   Child-2   Parent-1  Parent-2'
C     write(*,'(8i5)') ic11,ic12,ic21,ic22,ip11,ip12,ip21,ip22
C--------------------------- End Diagnostic Print
      return
      end
C end-of-fibd
C
C estimate ibd score for a pair of half-sibs -- parents known
C tabulations of number of genes expected shared ibd
C
      double precision function hibd(c11,c12,c21,c22,
     &                               p11,p12,pc1,pc2,p21,p22)
      integer KNOWN, MISS
      parameter(KNOWN=0, MISS=-9999)
      real c11,c12,c21,c22,p11,p12,pc1,pc2,p21,p22
      integer ic11,ic12,ic21,ic22,ip11,ip12,ipc1,ipc2,ip21,ip22
      integer tr1, tr2, nt1, nt2, cnallele, cnmiss
      logical  c1, c2

      hibd=0.25d0
C if homozygote common parent, no linkage information
      if (pc1.gt.KNOWN .and. pc1.eq.pc2) return

      ic11=int(c11)
      ic12=int(c12)
      ic21=int(c21)
      ic22=int(c22)
C
C deal with simplest cases
      call countall(ic11,ic12,ic21,ic22,cnallele,cnmiss)
      if (cnallele.eq.4 .or. (ic11.ne.ic21 .and. ic11.ne.ic22 .and.
     &    ic12.ne.ic21 .and. ic12.ne.ic22)) then
        hibd=0.0d0
        return
      end if
      ip11=MISS
      ip12=MISS
      ip21=MISS
      ip22=MISS
      if (p11.gt.KNOWN) ip11=int(p11)
      if (p12.gt.KNOWN) ip12=int(p12)
      if (p21.gt.KNOWN) ip21=int(p21)
      if (p22.gt.KNOWN) ip22=int(p22)
C
C missing common parent -- tr1 and tr2 are inferred transmitted alleles
C from the common parent to child 1 and 2; have already done
C sibpairs where unique genotypes
C
      if (pc1.le.KNOWN) then
        if (ic11.ne.ip11 .or. ic12.ne.ip12) then
          tr1=ic11
          if (ic11.eq.ip11 .or. ic11.eq.ip12) tr1=ic12
          if (ic21.ne.ip21 .or. ic22.ne.ip22) then
            tr2=ic21
            if (ic21.eq.ip21 .or. ic21.eq.ip22) tr2=ic22
            if (tr1.ne.tr2) hibd=0.0d0
          end if
        end if
        return
      else
        ipc1=int(pc1)
        ipc2=int(pc2)
      end if

      c1=(ipc1.eq.ip11 .and. ipc2.eq.ip12)
      c2=(ipc1.eq.ip21 .and. ipc2.eq.ip22)

      if (c1.and.c2) then
C
C 12 x 12 x 12 matings
        if (ic11.eq.ic12 .and. ic21.eq.ic22) then
          if (ic11.eq.ic21) then
            hibd=0.5d0
          elseif (ic11.ne.ic21) then
            hibd=0.0d0
          end if
        end if
      elseif ((c1.and..not.c2) .and. (ic11.eq.ic12)) then
C
C child1 not same genotype as 12 x 12 parents else hibd=0.25
C nt1 is the common parent's allele not transmitted to child1
        hibd=0.0d0
        nt1=ipc1
        if (ic11.eq.ipc1) nt1=ipc2
        if (ic21.ne.nt1 .and. ic22.ne.nt1) hibd=0.5d0
      elseif ((.not.c1.and.c2) .and.(ic21.eq.ic22)) then
C
C child2 not same genotype as 12 x 12 parents else hibd=0.25
C nt2 is the common parent's allele not transmitted to child2
        hibd=0.0d0
        nt2=ipc1
        if (ic21.eq.ipc1) nt2=ipc2
        if (ic11.ne.nt2 .and. ic12.ne.nt2) hibd=0.5d0
      elseif(.not.(c1.or.c2)) then
C
C !12 x 12 x !12 matings
        hibd=0.0d0
        nt1=ipc1
        if ((ic11.eq.ipc1 .and.(ic12.eq.ip11 .or.ic12.eq.ip12)) .or.
     2      (ic12.eq.ipc1 .and.(ic11.eq.ip11 .or. ic11.eq.ip12))) 
     3  then
          nt1=ipc2
        end if
        nt2=ipc1
        if ((ic21.eq.ipc1 .and.(ic22.eq.ip21 .or. ic22.eq.ip22)) .or.
     2      (ic22.eq.ipc1 .and.(ic21.eq.ip21 .or. ic21.eq.ip22))) 
     3  then
          nt2=int(pc2)
        end if
        if (nt1.eq.nt2) hibd=0.5d0
      end if
C
C     write(*,'(a,f5.3)') 'ibd=',hibd
C     write(*,*) 'Child-1   Child-2   Parent-1  Parent-12 Parent-2'
C     write(*,'(10fi.0)') ic11,ic12,ic21,ic22,ip11,ip12,ipc1,ipc2,ip21,ip22
      return
      end
C end-of-hibd
      
