C
C perform sibship association permutation test
C
      subroutine sibship(wrk,wrk2,trait,gene,mche,iter,mincnt,weight,
     2                   pedigree,num,nfound,id,fa,mo,sex,locus,
     3                   numloc,numal,name,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,weight,wrk,wrk2
      logical mche
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)
C array for allele counts in cases and controls
      integer cntall(MAXG,4)
C work arrays for counts and MC iteration
      integer aff(MAXSIZ),set(MAXSIZ,2)
C local variables
      integer contrib,gen2,i,it,j,k,nuntyp
      integer currf, currm, fin, nfam, sta, tailp
      logical last
C functions
      integer getnam
      double precision hibd, probst, regwt
C
      gen2=gene+1
      do 2 j=1,numal  
      do 2 k=1,3
        cntall(j,k)=0
    2 continue
      nfam=0
      nuntyp=0
      last=.false.
      rewind(wrk)
    5 continue
        call wrkin(wrk,pedigree,num,nfound,id,fa,mo,sex,locus,numloc,
     &             last)
        if (last) goto 20
C
C Full sibs
C
        famdf=0
        fin=num
        currf=fa(fin)
        currm=mo(fin)
        do 10 k=num-1,nfound,-1
          if (fa(k).ne.currf .or. mo(k).ne.currm) then
            contrib=0
            do 12 i=k+1,fin
            if (locus(i,trait).ne.MISS) then
              if (locus(i,gene).lt.KNOWN) then
                nuntyp=nuntyp+1
              else
                contrib=contrib+1
                aff(contrib)=int(isaff(locus(i,trait),thresh,gt))
                set(contrib,1)=getnam(locus(i,gene),numal,name)
                set(contrib,2)=getnam(locus(i,gen2),numal,name)
              end if
            end if
   12       continue
C
C Skip if no usable individuals in this sibship
C
            if (contrib.gt.1) then
              nfam=nfam+1
              do 14 i=1,contrib
                cntall(set(i,1),aff(i))=cntall(set(i,1),aff(i))+1
                cntall(set(i,2),aff(i))=cntall(set(i,2),aff(i))+1
   14         continue
              write(wrk2) contrib,(aff(i),set(i,1),set(i,2),i=1,contrib)
            end if
C Now update to next sibship
            fin=k
            currf=fa(fin)
            currm=mo(fin)
          end if
   10   continue
C mark end of sibships in current pedigree
      goto 5
   20 continue

      write(*,'(/a/a/a)') 
     2  '  --------- Sibship Permutation Analysis --------',
     3  '    Allele   Affected   Unaffected   Total    Dev',
     4  '  -----------------------------------------------'
      do 25 i=1,numal
        nco=nco+cntall(i,1)
        nca=nca+cntall(i,2)
   25 continue
      pexp=dfloat(nca)/dfloat(nca+nco)
      if (nca.eq.0) then
        casden=1.0
      else
        casden=float(nca)
      end if
      if (nco.eq.0) then
        conden=1.0
      else
        conden=float(nco)
      end if
      do 30 i=1,numal  
        cntall(i,3)=cntall(i,1)+cntall(i,2)
        if (cntall(i,3).gt.0) df=df+1
        write(*,'(i8,2(2x,i5,1x,a1,f3.2,a1),i8,1x,f6.1)') 
     2   name(i),cntall(i,2),'(',float(cntall(i,2))/casden,')',
     3   cntall(i,1),'(',float(cntall(i,1))/conden,')',cntall(i,3),
     4   binz(cntall(i,2),cntall(i,3),pexp)
   30 continue
      write(*,'(a/a8,2(2x,i5,6x),i8)') 
     2  '  -----------------------------------------------',
     3    'Total',nca,nco,nca+nco
      ochisq=twobyk(numal,cntall,pexp)

      write(*,'(3(/a,i6)') 
     2  '       No. trait(+) marker(-) =',nuntyp,
     3  '       No. trait(+) marker(+) =',(nca+nco)/2,
     4  '          No. useful sibships =',nfam 
      write(*,'(a,f6.1/a,i4/a,3x,f6.4)')
     2  '   Contingency Pearson chi-sq =',ochisq,
     3  '   Nominal degrees of freedom =',df,
     4  '              Nominal P-value =',chip(ochisq,df)
C
C MC P-value estimation
C
      if (iter.eq.0 .or. nfam.lt.1) return
C
C Now can simulate genotypes and do sequential P-value simulation
C
      it=0
      tailp=0
   49 continue
      if (it.eq.iter .or. tailp.eq. mincnt) goto 50
        it=it+1
        do 52 j=1,numal  
        do 52 k=1,3
          cntall(j,k)=0
   52   continue
        rewind(wrk2)
   55   continue
          read(wrk2,end=70) contrib,
     &      (aff(i),set(i,1),set(i,2),i=1,contrib)
          call setperm(contrib,set)
          do 65 i=1,num
          if (.not.untyped(i).and.(aff(i).eq.1.or.aff(i).eq.2)) then
            cntall(set(i,1),aff(i))=cntall(set(i,1),aff(i))+1
            cntall(set(i,2),aff(i))=cntall(set(i,2),aff(i))+1
          endif
   65     continue
        goto 55
   70   continue

        do 80 i=1,numal  
          cntall(i,3)=cntall(i,1)+cntall(i,2)
   80   continue
        chisq=twobyk(numal,cntall,pexp)
        call moment(it,chisq,mchisq,vchisq)
        if (chisq.gt.ochisq .or. (chisq.eq.ochisq .and.
     2      random().gt.0.5)) 
     3  then
          tailp=tailp+1
        end if
        if (plevel.gt.1) then
          write(*,'(/a,i4,a,f6.1)') 
     &      'Pseudosample ',it,': Chisq=',chisq
          do 85 i=1,numal
            write(*,'(i8,2(2x,i5,1x,a1,f3.2,a1),i8)') 
     2        name(i),cntall(i,2),'(',float(cntall(i,2))/float(nca),')',
     3        cntall(i,1),'(',float(cntall(i,1))/float(nco),')',
     4        cntall(i,3)
   85     continue
        end if
        goto 49
   50   continue
C   
        if (tailp.lt.mincnt) then
          tailp=tailp+1
          it=it+1
        end if
        vchisq=vchisq/dfloat(max(1,it-1))
        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 (',dfloat(tailp)/dfloat(it),')',
     4    ' Mean (Var) simulated chi-sqs =',mchisq,' (',vchisq,')'
      return
      end
C end-of-sibship
C
C Permute alleles of genotypes for set of sibs
C
      subroutine setperm(num,set)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer num  
      integer set(MAXSIZ,2)
C 
      integer i, swap, toa, tmp
C functions
      integer irandom

      do 20 i=1,num
      do 20 j=1,2
        swap=irandom(1,num)
        toa=irandom(1,2)
        tmp=set(swap,toa)
        set(swap,toa)=set(i,j)
        set(i,j)=tmp
   20 continue
      return
      end
C end-of-setperm
