C
C Two locus linkage disequilibrium: autosomal or X-linked loci
C
      subroutine twold(wrk,loctyp,gene1,loc1,gene2,loc2,iter,
     2             pedigree,actset,num,nfound,id,fa,mo,sex,locus,numloc,
     3             numal,name,alfrq,numal2,name2,alfrq2,
     4             eligible,ngcount,gcount,gfrq,plevel)
      integer MAXALL, MAXG, MAXSIZ, MAXLOC, KNOWN
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2, 
     &          MAXSIZ=1000, MAXLOC=120, KNOWN=0)
      integer gene1,gene2,iter,loctyp,plevel,wrk
      character*10 loc1, loc2
C pedigree structure
      character*10 pedigree
      integer sex(MAXSIZ)
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
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
C Typed founders or nonfounders who have untyped parents
      logical eligible(MAXSIZ)
C
C Genotype counts: allele1,allele2, number transmitted, number not trans
      integer ngcount,gcount(MAXG,4)
      double precision gfrq(MAXG)
C
      integer tr1,tr2,nt1,nt2,tr3,tr4,nt3,nt4
      logical last, xmale
      integer cutoff, df, gene12, gene22, i, idx, j, nhap, ntyped,
     &        tothap  
      character*3 histo
      character*7 gtp
      double precision asyp, bigd, chisq, d, dprime, e, hedrick, 
     &                 p1, p2, pval, tot
C functions 
      logical useld
      double precision chip, ftdev, getfreq
C
      if (plevel.gt.0) then
        write(*,'(/a,a10,a,a10,a/a/)')
     2   'Assoc for locus "',loc1,'" c. locus "',loc2,'"',
     3   '---------------------------------------------------'
      end if
      cutoff=0
      gene12=gene1+1
      gene22=gene2+1
      ntyped=0
      tothap=0
      ngcount=0
      do 2 i=1,numal
        alfrq(i)=0.0d0
        do 3 j=1,numal2
          ngcount=ngcount+1
          gcount(ngcount,1)=name(i)
          gcount(ngcount,2)=name2(j)
          gcount(ngcount,3)=0
    3   continue
    2 continue
      do 4 j=1,numal2
        alfrq2(j)=0.0d0
    4 continue

      last=.false.
      rewind(wrk)
C
C If high print level, then list transmitted and nontransmitted alleles
C for each informative proband
C
      if (plevel.gt.1) then
        write(*,'(a/a)') '  Informative Parent     Trans  Not Tr',
     &                   'Pedigree  ID      Sex    1   2   1   2'
      end if
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
C
C Identify typed founders or nonfounders who have untyped parents
C
         do 11 i=1,nfound
           if (locus(i,gene1).gt.KNOWN .and.locus(i,gene2).gt.KNOWN)
     &     then
             eligible(i)=.true.
           else
             eligible(i)=.false.
           end if
   11    continue
         do 12 i=nfound+1,num
           if (locus(i,gene1).gt.KNOWN .and.locus(i,gene2).gt.KNOWN 
     2         .and. locus(fa(i),gene1).lt.KNOWN
     3         .and. locus(fa(i),gene2).lt.KNOWN
     4         .and. locus(mo(i),gene1).lt.KNOWN
     5         .and. locus(mo(i),gene2).lt.KNOWN)  then
             eligible(i)=.true.
           else
             eligible(i)=.false.
           end if
   12    continue
C
C Go through eligible offspring
C
         do 15 i=nfound+1,num
           if ((eligible(fa(i)) .or. eligible(mo(i))) .and.
     2         useld(locus(i,gene1),locus(i,gene12),locus(i,gene2),
     3           locus(i,gene22),locus(fa(i),gene1),locus(fa(i),gene12),
     4           locus(fa(i),gene2), locus(fa(i),gene22),
     5           locus(mo(i),gene1),locus(mo(i),gene12),
     6           locus(mo(i),gene2),locus(mo(i),gene22))) then
             xmale=(sex(i).eq.1 .and. loctyp.eq.2)
             if (xmale) then
               call xtrans(
     3             int(locus(mo(i),gene1)), int(locus(mo(i),gene12)),
     4             int(locus(i,gene1)), int(locus(i,gene12)),
     5             tr1,tr2,nt1,nt2)
               call xtrans(
     3             int(locus(mo(i),gene2)), int(locus(mo(i),gene22)),
     4             int(locus(i,gene2)), int(locus(i,gene22)),
     5             tr3,tr4,nt3,nt4)
             else
               call trans(
     2             int(locus(fa(i),gene1)), int(locus(fa(i),gene12)),
     3             int(locus(mo(i),gene1)), int(locus(mo(i),gene12)),
     4             int(locus(i,gene1)), int(locus(i,gene12)),
     5             tr1,tr2,nt1,nt2,0)
               call trans(
     2             int(locus(fa(i),gene2)), int(locus(fa(i),gene22)),
     3             int(locus(mo(i),gene2)), int(locus(mo(i),gene22)),
     4             int(locus(i,gene2)), int(locus(i,gene22)),
     5             tr3,tr4,nt3,nt4,0)
             end if
C
C Note that once the haplotypes are used, the parent is set to ineligible
C along with any other full or half siblings
C
             if (eligible(fa(i)) .and. .not.xmale) then
               idx=fa(i)
               ntyped=ntyped+1
               if (tr2.gt.KNOWN .and. tr4.gt.KNOWN) then
                 tothap=tothap+1
                 call insgen(tr2,tr4,ngcount,gcount,3,2)
                 call insall(tr2,numal,name,alfrq)
                 call insall(nt2,numal,name,alfrq)
               end if
               if (loctyp.eq.1) then
                 tothap=tothap+1
                 call insgen(nt2,nt4,ngcount,gcount,3,2)
                 call insall(tr4,numal2,name2,alfrq2)
                 call insall(nt4,numal2,name2,alfrq2)
               end if
               eligible(idx)=.false.
               if (idx.gt.nfound) then
                 do 21 j=nfound+1,num
                   if (eligible(j) .and. 
     &                 (fa(idx).eq.fa(j) .or.  mo(idx).eq.mo(j))) then
                     eligible(j)=.false.
                   end if
   21            continue
               end if
               if (plevel.gt.1) then
                 write(*,'(a10,a8,x,a1,2x,4(1x,i3))') 
     &           pedigree,id(idx),'m',tr2,tr4, nt2, nt4
               end if
             end if
             if (eligible(mo(i))) then
               idx=mo(i)
               ntyped=ntyped+1
               tothap=tothap+2
               call insgen(tr1,tr3,ngcount,gcount,3,2)
               call insgen(nt1,nt3,ngcount,gcount,3,2)
               call insall(tr1,numal,name,alfrq)
               call insall(nt1,numal,name,alfrq)
               call insall(tr3,numal2,name2,alfrq2)
               call insall(nt3,numal2,name2,alfrq2)
               eligible(idx)=.false.
               if (idx.gt.nfound) then
                 do 22 j=nfound+1,num
                   if (eligible(j) .and. 
     &                 (fa(idx).eq.fa(j) .or.  mo(idx).eq.mo(j))) then
                     eligible(j)=.false.
                   end if
   22            continue
               end if
               if (plevel.gt.1) then
                 write(*,'(a10,a8,x,a1,2x,4(1x,i3))') 
     &             pedigree,id(idx),'f',tr1,tr3, nt1, nt3 
               end if
             end if
           end if
   15    continue
       goto 10
   20  continue
C
      if (plevel.gt.0) then
       write(*,'(2a/2a)') 
     2   '       Haplotype       Observed   Expected',
     3   '     D        D''      Dev',
     4   '  ----------------------------------------',
     5   '-------------------------'
      end if
      asyp=1.0d0
      chisq=0.0d0
      bigd=0.0d0
      hedrick=0.0d0
      pval=1.0d0
      tot=0.0d0
      if (ntyped.gt.0) then
        tot=dfloat(tothap)
        do 225 i=1,ngcount
          p1=getfreq(gcount(i,1),numal,name,alfrq)/tot 
          p2=getfreq(gcount(i,2),numal2,name2,alfrq2)/tot
          e=tot*p1*p2
          gfrq(i)=e
          nhap=gcount(i,3)
          if (nhap.gt.cutoff) then
            chisq=chisq+dfloat(nhap)*
     &            log(dfloat(nhap)/e)
          end if    
          d=(dfloat(nhap)-e)/tot
          if (d.lt.0.0d0) then
            dprime=d/min(p1*p2,(1.0d0-p1)*(1.0d0-p2))
          elseif (d.eq.0.0d0) then
            dprime=0.0d0
          else
            dprime=d/(min(p1,p2)-p1*p2)
          end if
          if (abs(dprime).gt.bigd) bigd=abs(dprime)
          hedrick=hedrick+p1*p2*abs(dprime)

          if (plevel.gt.0) then
            call wrgtp(gcount(i,1),gcount(i,2),gtp,2)
            write(*,999) gtp,nhap,'(',dfloat(nhap)/tot,')',e,
     &                   d,dprime,ftdev(dfloat(nhap),e)
  999       format(8x,a7,1x,i8,1x,1a,f5.3,1a,1x,f9.1,2x,f7.4,
     &             2x,f7.4,1x,f6.1)
          end if
  225   continue

        chisq=chisq+chisq
        df=(numal-1)*(numal2-1)
        asyp=chip(chisq,df)

        call simchi(numal,name,alfrq,numal2,name2,alfrq2,gcount,
     &              gfrq,chisq,tothap,iter,pval)
      end if 
      if (plevel.gt.0) then
        write(*,'(/a,i4/a,3x,f6.4/a,f6.1/a,i4)')
     2  '   Number of individuals used =',ntyped,
     2  '          Pooled D'' (Hedrick) =',hedrick,
     3  'Linkage disequilibrium Chi-sq =',chisq,
     4  '   Nominal degrees of freedom =',df
        write(*,'(14x,a,3x,f6.4)') 'Nominal P-value =',asyp
        write(*,'(14x,a,3x,f6.4,a,i8,a)') 'Empiric P-value =',pval,
     &    ' (',10*int(tot)*iter,' MCMC iterations)'
      else
        call phist(pval,1.0d0,histo)
        write(*,'(2(a10,1x),i4,2x,f6.3,1x,f6.1,1x,i4,1x,f6.4,2(1x,a))')
     &    loc1,loc2,ntyped,hedrick,chisq,df,pval,'LD ',histo
      end if
C
      return
      end
C end-of-twold
C
C MCMC a RxC contingency table retaining given margins
C
      subroutine simchi(nr, rows, rfrq, nc, cols, cfrq,tble, e, obschi, 
     &                  tot, iter, pval)
      integer MAXALL, MAXG
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2) 
      integer iter, nc, nr, tot
      double precision obschi, pval
C
      integer cols(MAXALL), rows(MAXALL), tble(MAXG,4)
      double precision cfrq(MAXALL), rfrq(MAXALL), e(MAXG)

      integer c1, c2, eligc, eligr, i, incr, ip,
     &        it, ncells, r1, r2, isub(4)
      double precision chisq, qa
C functions
      integer irandom
      real random

      pval=1.0d0
      call mkchoose(nr, rows, rfrq, eligr)
      call mkchoose(nc, cols, cfrq, eligc)
      
      if (eligr.lt.2 .or. eligc.lt.2) return

      ip=0
      ncells=nr*nc
      chisq=obschi
      do 10 it=1, 10*iter
C dememorise by sampling each tot'th value
        do 50 i=1, tot 
          call choose(2, eligr, rows)
          call choose(2, eligc, cols)
          r1=rows(1)
          r2=rows(2)
          c1=cols(1)
          c2=cols(2)
          call order(r1,r2)
          call order(c1,c2)
          isub(1)=nc*(r1-1)+c1
          isub(2)=nc*(r1-1)+c2
          isub(3)=nc*(r2-1)+c1
          isub(4)=nc*(r2-1)+c2
          incr=2*irandom(1,2)-3
          qa=0.0d0
          if (incr.eq.-1 .and. tble(isub(1),3).gt.0 .and.
     &        tble(isub(4),3).gt.0) then
            qa=min(1.0d0,dfloat(tble(isub(1),3)*tble(isub(4),3))/
     &                  dfloat((tble(isub(2),3)+1)*(tble(isub(3),3)+1)))
          else if (incr.eq.1 .and. tble(isub(2),3).gt.0 .and.
     &             tble(isub(3),3).gt.0) then
            qa=min(1.0d0,dfloat(tble(isub(2),3)*tble(isub(3),3))/
     &                  dfloat((tble(isub(1),3)+1)*(tble(isub(4),3)+1)))
          end if
C If accepted, update genotypes
C
          if (qa.gt.random()) then
            tble(isub(1),3)=tble(isub(1),3)+incr
            tble(isub(2),3)=tble(isub(2),3)-incr
            tble(isub(3),3)=tble(isub(3),3)-incr
            tble(isub(4),3)=tble(isub(4),3)+incr
          end if
C         write(*,*) 'R1,R2,C1,C2:',r1,r2,c1,c2,
C    &               (tble(kk,3), kk=1, ncells)
   50   continue
        call upchi(ncells, tble, e, chisq)
C     write(*,*) chisq, (tble(kk,3), kk=1, ncells)
        if (chisq.ge.obschi) ip=ip+1
   10 continue
      pval=dfloat(ip)/dfloat(10*iter)
      return
      end
C end-of-simchi
C 
C LRTS for contingency table in MCMC
C
      subroutine upchi(ncells, tble, e, lrts)
      integer MAXALL, MAXG
      double precision TOL 
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2,TOL=1.0d-6) 

      integer ncells
      double precision lrts
      integer tble(MAXG,4)
      double precision e(*)
      integer i, icount

      lrts=0.0d0
      do 10 i=1,ncells
      if (tble(i,3).gt.0 .and. e(i).gt.TOL) then
        icount=tble(i,3)
        lrts=lrts+dfloat(icount)*log(dfloat(icount)/e(i))
      end if
   10 continue
      lrts=lrts+lrts
      return
      end
C end-of-upchi
C   
C Load an array with indices of eligible choices (eg nonmissing alleles)
      subroutine mkchoose(ni, idx, eligible , nelig)
      integer nelig, ni, idx(ni)
      double precision eligible(ni)
      integer i
      nelig=0
      do 5 i=1, ni
      if (eligible(i).gt.0.0d0) then
        nelig=nelig+1
        idx(nelig)=i
      end if
    5 continue
      return
      end
C end-of-mkchoose
C
C Shuffle array of indices so can randomly select combination from
C as first r elements
      subroutine choose(nch, ni, idx)
      integer nch, ni, idx(ni)
      integer i, pos, tmp
C functions
      integer irandom

      do 5 i=1, nch
        pos=irandom(1, ni)
        tmp=idx(pos)
        idx(pos)=idx(i)
        idx(i)=tmp
    5 continue
      return
      end
C end-of-choose
C
C simple increment of allele count where all alleles already identified
C
      subroutine insall(iall,numal,name,alfrq)
      integer MAXALL
      parameter(MAXALL=60)
      integer iall, numal, name(MAXALL)
      double precision alfrq(MAXALL)
      integer idx
C functions
      integer getnam
      idx=getnam(float(iall),numal,name)
      alfrq(idx)=alfrq(idx)+1.0d0
      return
      end
C end-of-insall
C
C Check if useful triad for haplotype inference 
C
      logical function useld(c1,c2,c3,c4,f1,f2,f3,f4,m1,m2,m3,m4)
      integer KNOWN
      parameter(KNOWN=0)
      real c1,c2,c3,c4,f1,f2,f3,f4,m1,m2,m3,m4
      logical het1, het2, hom1, hom2

      useld=.false.
      if (c1.le.KNOWN .or. c3.le.KNOWN) return
      if (f1.le.KNOWN .or. f3.le.KNOWN) return
      if (m1.le.KNOWN .or. m3.le.KNOWN) return
C drop out uninformative triads: eg 1.2/3.4 x 1.2/1.3 -> 1.2/3.3
C                      but keep: eg 1.2/3.3 x 1.2/3.3 -> 1.2/3.3
      het1=(c1.eq.f1 .and. c2.eq.f2 .and. c1.eq.m1 .and. c2.eq.m2 .and.
     &      c1.ne.c2)
      hom1=(f1.eq.f2 .and. m1.eq.m2 .and. f1.eq.m1)
      het2=(c3.eq.f3 .and. c4.eq.f4 .and. c3.eq.m3 .and. c4.eq.m4 .and.
     &      c3.ne.c4)
      hom2=(f3.eq.f4 .and. m3.eq.m4 .and. f3.eq.m3)

      if (het1 .and. .not.hom2) return
      if (het2 .and. .not.hom1) return
      
      useld=.true.
      return
      end
C end-of-useld
C
C Additive allelic model for association with a quantitative trait
C
      subroutine doanova(wrk,wrk2,trait,locnam,gene,iter,mincnt,assfnd,
     2              x,r,b,cov,pedigree,actset,num,nfound,
     3              id,fa,mo,sex,locus,numloc,numal,name,cumfrq,
     4              untyped,value,count,set,plevel)
      integer KNOWN,MAXIBD,MAXSIZ,MAXLOC,MAXALL,MAXCOV,MAXTER,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MAXALL=60,MAXIBD=1000,
     2           MAXTER=MAXIBD/2,MAXCOV=MAXTER*(MAXTER+1)/2,
     3           MISS=-9999)
      integer gene,iter,mincnt,numal,numloc,plevel,trait,wrk,wrk2
      logical assfnd
      character*10 locnam
C Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ), set(MAXSIZ,2)
      real locus(MAXSIZ,MAXLOC)
      logical last, untyped(MAXSIZ)
C allele frequencies structure
      integer name(MAXALL)
      double precision cumfrq(MAXALL)
C Storage for trait values during randomization
      integer count(MAXSIZ)
      real value(MAXSIZ)
C arrays for allelic effects
      double precision x(MAXTER), r(MAXCOV), b(MAXTER), cov(MAXCOV)
C local variables
      integer g1,g2,gen2,i,idf,ii,it,j,mdf,n,ncov,nobs,nter,tailp,nuntyp
      character*3 histo
      double precision asyp, bss, orss, lrts, mss,mu,pval,rss,vss
C functions
      integer getnam
      real random
      double precision chip, ln

      last=.false.
      it=0
      nobs=0
      nter=numal+1
      ncov=nter*(nter+1)/2
      gen2=gene+1
      call inicov(nter, ncov, r)
      bss=0.0d0
      mu=0.0d0
      nuntyp=0
      do 5 i=1,numal
        count(i)=0
    5 continue
      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
        n=num
        if (assfnd) n=nfound
        do 12 i=1,n
          value(i)=locus(i,trait)
          untyped(i)=.false.
          if (locus(i,gene).lt.KNOWN) then
            untyped(i)=.true.
            if (locus(i,trait).ne.MISS) nuntyp=nuntyp+1
          elseif (locus(i,trait).ne.MISS) then
            g1=getnam(locus(i,gene),numal,name)
            g2=getnam(locus(i,gen2),numal,name)
            nobs=nobs+1
            do 15 j=1,numal
              x(j)=0.0d0
   15       continue
            x(nter)=dble(value(i))
            x(g1)=x(g1)+1
            x(g2)=x(g2)+1
            count(g1)=count(g1)+1
            count(g2)=count(g2)+1
            call moment(nobs,x(nter),mu,bss)
            call givenc(r, ncov, nter, x, 1.0d0, ifail)
          end if
   12   continue
        write(wrk2) n,nfound,(value(i),fa(i),mo(i),untyped(i),i=1,n)
      goto 10
   20 continue
      call alias(r, ncov, nter, 1.0d-15, x, ifail)
      call bsub(r, ncov, nter, b, numal, ifail)
      call var(r, ncov, cov, ncov, nter, nobs, 1, ifail)

      mdf=0
      mss=0.0d0
      do 150 i=1,numal
        call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail)
        mdf=mdf+idf
        mss=mss+rss
  150 continue
      call sscomp(r, ncov, nter, nobs, 0, orss, idf, ifail)

      lrts=dfloat(nobs) * (ln(bss)-ln(orss))
      asyp=chip(lrts,max(1,mdf-1))
      mss=mss/dfloat(max(1,mdf))
      orss=orss/dfloat(max(1,idf))

      if (plevel.gt.0) then
        write(*,'(/3a/a/a)') 
     2    '  ------ QTL Association with "',locnam,'" -----',
     3    '    Allele   Allelic Mean    Stand Error   Count',
     4    '  ----------------------------------------------'
        ii=0
        do 155 i=1,numal
          ii=ii+i
          write(*,'(2x,i8,3x,f12.4,3x,f12.4,1x,i7)') 
     &       name(i),b(i),sqrt(cov(ii)),count(i)
  155   continue
        write(*,'(a/a,f12.4,3x,f12.4,1x,i7)') 
     2    '  ----------------------------------------------',
     3    '  Total      ',mu, sqrt(bss/dfloat(max(1,nobs-1))), 2*nobs
        write(*,'(2(/a,i7),2(/a,f12.4,a,i4,a))') 
     3    ' No. trait(+) marker(-)  =',nuntyp,
     4    ' No. trait(+) marker(+)  =',nobs,
     5    ' Model Mean Square       =', mss,' (df=',mdf,')',
     6    ' Mean Square Error       =',orss,' (df=',idf,')'
        write(*,'(a,f12.4,/a,f12.4)')
     2    ' Likelihood ratio test   =',lrts,
     3    ' Nominal P-value         =',asyp
      end if

      if (iter.gt.0) then
    
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
        mss=0.0d0
        vss=0.0d0
        tailp=0
   49   continue
        if (it.eq.iter .or. tailp.eq. mincnt) goto 50
          it=it+1
          call inicov(nter, ncov, r)
          rewind(wrk2)
   55     continue
            read(wrk2,end=70) n,nfound,
     &        (value(i),fa(i),mo(i),untyped(i),i=1,n)
            call simped(n,nfound,fa,mo,cumfrq,set)
            do 60 i=1,n
            if (.not.untyped(i).and.value(i).ne.MISS) then
              do 65 j=1,numal
                x(j)=0.0d0
   65         continue
              x(nter)=dble(value(i))
              x(set(i,1))=x(set(i,1))+1
              x(set(i,2))=x(set(i,2))+1
              call givenc(r, ncov, nter, x, 1.0d0, ifail)
            end if
   60       continue
          goto 55
   70     continue
          call alias(r, ncov, nter, 1.0d-15, x, ifail)
          call sscomp(r, ncov, nter, nobs, 0, rss, idf, ifail)
          rss=rss/dfloat(max(1,idf))
          call moment(it,rss,mss,vss)
          if (rss.lt.orss .or. (rss.eq.orss .and. 
     2        random().gt.0.5d0))  then
            tailp=tailp+1
          end if
          if (plevel.gt.1) then
            write(*,'(/a,i4,a,f12.4)') 
     &       'Pseudosample ',it,': MSE=',rss
          end if
          goto 49
   50   continue
        if (tailp.lt.mincnt) then
          tailp=tailp+1
          it=it+1
        end if
        vss=vss/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,f12.4,a,f12.4,a)')
     2    ' Equalled or exceeded by =',tailp,'/',it,
     3    ' simulated values (',pval,')',
     4    ' Mean (SD) simulated MSE =',mss,' (',sqrt(vss),')'
      else
        call phist(asyp,pval,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     &    locnam, nobs, mdf, lrts, asyp, pval, it, 'ANOVA-HWE',histo
      end if
      return
      end
C end-of-doanova
C
C Additive allelic model for association with a quantitative trait
C Conditional on parental genotypes
C
      subroutine qtdt(wrk,wrk2,trait,locnam,gene,iter,mincnt,
     2             x,r,b,cov,pedigree,actset,num,nfound,
     3             id,fa,mo,sex,locus,numloc,
     4             numal,name,untyped,value,count,set,plevel)
      integer KNOWN,MAXIBD,MAXSIZ,MAXLOC,MAXALL,MAXCOV,MAXTER,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MAXALL=60,MAXIBD=1000,
     2           MAXTER=MAXIBD/2,MAXCOV=(MAXALL+1)*(MAXALL+2)/2,
     3           MISS=-9999)
      integer gene,iter,mincnt,numal,numloc,plevel,trait,wrk,wrk2
      character*10 locnam
C Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ), set(MAXSIZ,2)
      real locus(MAXSIZ,MAXLOC)
      logical last, untyped(MAXSIZ)
C allele frequencies structure
      integer name(MAXALL)
C Storage for trait values during randomization
      integer count(MAXSIZ)
      real value(MAXSIZ)
C arrays for allelic effects
      double precision x(MAXTER), r(MAXCOV), b(MAXTER), cov(MAXCOV)
C local variables
      integer contrib,gen2,i,idf,ii,it,j,mdf,ncov,nobs,nter,tailp,nuntyp
      character*3 histo
      double precision asyp,bss,lrts,mss,mu,pval,orss,rss,vss
C functions
      integer getnam
      real random
      double precision chip, ln

      last=.false.
      nobs=0
      nter=numal+1
      ncov=nter*(nter+1)/2
      gen2=gene+1
      call inicov(nter, ncov, r)
      mu=0.0d0
      bss=0.0d0
      nuntyp=0
      do 5 i=1,numal
        count(i)=0
    5 continue
      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
C load set() with genotypes
        do 11 i=1,num
          untyped(i)=.false.
          value(i)=MISS
          if (locus(i,gene).lt.KNOWN) then
            untyped(i)=.true.
            set(i,1)=MISS
            set(i,2)=MISS
          else
            set(i,1)=getnam(locus(i,gene),numal,name)
            set(i,2)=getnam(locus(i,gen2),numal,name)
          end if
   11   continue
C
C Only phenotyped persons with genotyped parents used-> value() set to trait
        contrib=0
        do 12 i=nfound+1,num
          if (locus(i,trait).ne.MISS .and. .not.untyped(i) .and.
     &        .not.untyped(fa(i)) .and. .not.untyped(mo(i))) then
            contrib=contrib+1
            value(i)=locus(i,trait)
            nobs=nobs+1
            do 15 j=1,numal
              x(j)=0.0d0
   15       continue
            x(nter)=dble(value(i))
            x(set(i,1))=x(set(i,1))+1
            x(set(i,2))=x(set(i,2))+1
            count(set(i,1))=count(set(i,1))+1
            count(set(i,2))=count(set(i,2))+1
            call moment(nobs,x(nter),mu,bss)
            call givenc(r, ncov, nter, x, 1.0d0, ifail)
          end if
   12   continue
        if (contrib.gt.0) then
          write(wrk2) num,nfound,
     &     (value(i),fa(i),mo(i),untyped(i),set(i,1),set(i,2),i=1,num) 
        end if
      goto 10
   20 continue

      if (nobs.eq.0) then
        if (plevel.gt.0) then
          write(*,'(/3a/a/a/2(/a,i7))') 
     2    '  ------ QTL Association with "',locnam,'"-------',
     3    '  ------ Conditioned on Parental Genotype -------',
     4    '  -----------------------------------------------',
     5    ' No. trait(+) marker(-)  =',nuntyp,
     6    ' No. trait(+) marker(+)  =',nobs 
        else
          write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,1x,a)')
     &    locnam, nobs, 0, 0.0d0, 1.0d0, 1.0d0, 0, 'ANOVA-CPG .'
        end if
        return
      end if
      call alias(r, ncov, nter, 1.0d-15, x, ifail)
      call bsub(r, ncov, nter, b, numal, ifail)
      call var(r, ncov, cov, ncov, nter, nobs, 1, ifail)
      mdf=0
      mss=0.0d0
      do 150 i=1,numal
        call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail)
        mdf=mdf+idf
        mss=mss+rss
  150 continue
      call sscomp(r, ncov, nter, nobs, 0, orss, idf, ifail)
      lrts=dfloat(nobs) * (ln(bss)-ln(orss))
      asyp=chip(lrts,max(1,mdf-1))
      mss=mss/dfloat(max(1,mdf))
      orss=orss/dfloat(max(1,idf))
      if (plevel.gt.0) then
        write(*,'(/3a/a/a/a)') 
     2  '  ------ QTL Association with "',locnam,'"-------',
     3  '  ------ Conditioned on Parental Genotype -------',
     4  '    Allele   Allelic Mean    Stand Error   Count',
     5  '  -----------------------------------------------'
      ii=0
      do 155 i=1,numal
        ii=ii+i
        write(*,'(2x,i8,3x,f12.4,3x,f12.4,1x,i7)') 
     &     name(i),b(i),sqrt(cov(ii)),count(i)
  155 continue
        write(*,'(a/a,f12.4,3x,f12.4,1x,i7)') 
     2    '  ----------------------------------------------',
     3    '  Total      ',mu, sqrt(bss/dfloat(max(1,nobs-1))), 2*nobs
        write(*,'(2(/a,i7),2(/a,f12.4,a,i4,a))') 
     3  ' No. trait(+) marker(-)  =',nuntyp,
     4  ' No. trait(+) marker(+)  =',nobs,
     5  ' Model Mean Square       =', mss,' (df=',mdf,')',
     6  ' Mean Square Error       =',orss,' (df=',idf,')'
        write(*,'(a,f12.4,/a,f12.4)')
     2    ' Likelihood ratio test   =',lrts,
     3    ' Nominal P-value         =',asyp
      end if
      if (iter.gt.0) then
    
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
        mss=0.0d0
        vss=0.0d0
        it=0
        tailp=0
   49   continue
        if (it.eq.iter .or. tailp.eq. mincnt) goto 50
          it=it+1
          call inicov(nter, ncov, r)
          rewind(wrk2)
   55     continue
            read(wrk2,end=70) num,nfound,
     &      (value(i),fa(i),mo(i),untyped(i),set(i,1),set(i,2),i=1,num) 
            call csimped(num,nfound,fa,mo,untyped,set)
            do 60 i=1,num
            if (value(i).ne.MISS) then
              do 65 j=1,numal
                x(j)=0.0d0
   65         continue
              x(nter)=dble(value(i))
              x(set(i,1))=x(set(i,1))+1
              x(set(i,2))=x(set(i,2))+1
              call givenc(r, ncov, nter, x, 1.0d0, ifail)
            end if
   60       continue
          goto 55
   70     continue
          call alias(r, ncov, nter, 1.0d-15, x, ifail)
          call sscomp(r, ncov, nter, nobs, 0, rss, idf, ifail)
          rss=rss/dfloat(max(1,idf))
          call moment(it,rss,mss,vss)
          if (rss.lt.orss .or. (rss.eq.orss .and. 
     2        random().gt.0.5d0))  then
            tailp=tailp+1
          end if
          if (plevel.gt.1) then
            write(*,'(/a,i4,a,f12.4)') 
     &       'Pseudosample ',it,': MSE=',rss
          end if
          goto 49
   50   continue
        if (tailp.lt.mincnt) then
          tailp=tailp+1
          it=it+1
        end if
        vss=vss/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,f12.4,a,f12.4,a)')
     2    ' Equalled or exceeded by =',tailp,'/',it,
     3    ' simulated values (',pval,')',
     4    ' Mean (SD) simulated MSE =',mss,' (',sqrt(vss),')'
      else
        call phist(asyp,pval,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     &    locnam, nobs, mdf, lrts, asyp, pval, it, 'ANOVA-CPG',histo
      end if
      return
      end
C end-of-qtdt
C
C Count of marker alleles/genotyped in cases and controls -- codominant system
C
      subroutine doassoc(wrk,wrk2,trait,locnam,gene,iter,mincnt,assfnd,
     2                   gt,thresh,pedigree,actset,num,nfound,id,fa,mo,
     3                   sex,locus,numloc,numal,name,cntall,cumfrq,
     4                   aff,untyped,set,plevel,typ)
      integer KNOWN,MAXSIZ,MAXLOC,MAXALL,MAXG,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MAXALL=60,
     &           MAXG=MAXALL*(MAXALL+1)/2,MISS=-9999)
      integer gene,iter,mincnt,numal,numloc,plevel,trait,typ,wrk,wrk2
      real thresh
      logical assfnd, gt
      character*10 locnam
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)
      logical last
C work arrays
      integer aff(MAXSIZ), set(MAXSIZ,2)
      logical untyped(MAXSIZ)
C allele frequencies structure
      integer name(MAXALL)
      double precision cumfrq(MAXALL)
C array for allele counts in cases and controls
      integer cntall(MAXG,4)
C F statistics
      integer eh1, eh2, eh12, nhom(2)
      double precision h0, hs, ht, fis, fit, fst, d1, d2
C other local variables
      integer g1,g2,i,it,df,gen2,gtp,nca,ncats,nco,nuntyp,tailp
      character*3 histo, ana
      real casden, conden
      double precision asyp, chisq, mchisq, ochisq, pexp, pval, vchisq
C functions
      integer clcpos, getnam
      real isaff, random
      double precision twobyk, chip, binz

      ncats=numal
      ana='HWE'
      if (typ.eq.2) then
        ncats=numal*(numal+1)/2
        ana='Gtp'
      end if
        
      df=-1
      gen2=gene+1
      nhom(1)=0
      nhom(2)=0
      nuntyp=0
      do 2 j=1,ncats  
      do 2 k=1,3
        cntall(j,k)=0
    2 continue
      if (typ.eq.1) then
        do 3 j=1, ncats
          cntall(j,4)=name(j)
    3   continue
      else
        do 4 j=1, ncats
          cntall(j,4)=j
    4   continue
      end if
      mchisq=0.0d0
      vchisq=0.0d0
      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 (assfnd) then
          if (typ.eq.1) then
            do 12 i=1,nfound
              aff(i)=int(isaff(locus(i,trait),thresh,gt))
              if (locus(i,gene).lt.KNOWN) then
                if (aff(i).ne.MISS) nuntyp=nuntyp+1
              elseif (aff(i).eq.1.or.aff(i).eq.2) then
                g1=getnam(locus(i,gene),numal,name)
                g2=getnam(locus(i,gen2),numal,name)
                cntall(g1,aff(i))=cntall(g1,aff(i))+1
                cntall(g2,aff(i))=cntall(g2,aff(i))+1
                if (g1.eq.g2) nhom(aff(i))=nhom(aff(i))+1
              endif
   12       continue
          else
            do 13 i=1,nfound
              aff(i)=int(isaff(locus(i,trait),thresh,gt))
              if (locus(i,gene).lt.KNOWN) then
                if (aff(i).ne.MISS) nuntyp=nuntyp+1
              elseif (aff(i).eq.1.or.aff(i).eq.2) then
                g1=getnam(locus(i,gene),numal,name)
                g2=getnam(locus(i,gen2),numal,name)
                gtp=clcpos(g1,g2)
                cntall(gtp,aff(i))=cntall(gtp,aff(i))+1
              endif
   13       continue
          end if
        else
          if (typ.eq.1) then
            do 14 i=1,num
              untyped(i)=.false.
              aff(i)=int(isaff(locus(i,trait),thresh,gt))
              if (locus(i,gene).lt.KNOWN) then
                untyped(i)=.true.
                if (aff(i).ne.MISS) nuntyp=nuntyp+1
              elseif (aff(i).eq.1.or.aff(i).eq.2) then
                g1=getnam(locus(i,gene),numal,name)
                g2=getnam(locus(i,gen2),numal,name)
                cntall(g1,aff(i))=cntall(g1,aff(i))+1
                cntall(g2,aff(i))=cntall(g2,aff(i))+1
                if (g1.eq.g2) nhom(aff(i))=nhom(aff(i))+1
              endif
   14       continue
          else
            do 15 i=1,num
              untyped(i)=.false.
              aff(i)=int(isaff(locus(i,trait),thresh,gt))
              if (locus(i,gene).lt.KNOWN) then
                untyped(i)=.true.
                if (aff(i).ne.MISS) nuntyp=nuntyp+1
              elseif (aff(i).eq.1.or.aff(i).eq.2) then
                g1=getnam(locus(i,gene),numal,name)
                g2=getnam(locus(i,gen2),numal,name)
                gtp=clcpos(g1,g2)
                cntall(gtp,aff(i))=cntall(gtp,aff(i))+1
              endif
   15       continue
          end if
          write(wrk2) num,nfound,
     &      (aff(i),fa(i),mo(i),untyped(i),i=1,num)
        end if
      goto 10
   20 continue
C
      eh1=0
      eh2=0
      eh12=0
      nca=0
      nco=0
      do 25 i=1,ncats 
        nco=nco+cntall(i,1)
        nca=nca+cntall(i,2)
        cntall(i,3)=cntall(i,1)+cntall(i,2)
        if (cntall(i,3).gt.0) df=df+1
   25 continue
C F statistics calculated if allelic test
      if (typ.eq.1) then
        do 26 i=1,ncats 
          eh1=eh1+cntall(i,1)*cntall(i,1)
          eh2=eh2+cntall(i,2)*cntall(i,2)
          eh12=eh12+cntall(i,1)*cntall(i,2)
   26   continue
        d1=max(1.0d0,dfloat(nco))
        d2=max(1.0d0,dfloat(nca))
        h0=1.0d0-dfloat(nhom(1))/d1-dfloat(nhom(2))/d2
        hs=0.5d0*(dfloat(nco*(nco-1)
     2     +2*nhom(1)-eh1)/d1/max(1.0d0,d1-2.0d0)
     3     +dfloat(nca*(nca-1)+2*nhom(2)-eh2)/d2/max(1.0d0,d2-2.0d0))
        ht=1.0d0-dfloat(eh12)/d1/d2
        fis=(hs-h0)/hs
        fit=(ht-h0)/ht
        fst=(ht-hs)/ht
      end if
C Calculate association statistic
      if (nca.gt.0 .and. nco.gt.0) then
        pexp=dfloat(nca)/dfloat(nca+nco)
        ochisq=twobyk(ncats,cntall,pexp)
        asyp=chip(ochisq,df)
      else
        pexp=0.0d0
        ochisq=0.0d0
        asyp=1.0d0
      end if

      if (plevel.gt.0) then
        write(*,'(/3a/a/a)') 
     2    '  ---- Association Analysis for "',locnam,'"----',
     3    '    Allele   Affected   Unaffected   Total    Dev',
     4    '  -----------------------------------------------'
        casden=max(1.0,float(nca))
        conden=max(1.0,float(nco))
        do 30 i=1,ncats  
          write(*,'(i8,2(2x,i5,1x,a1,f3.2,a1),i8,1x,f6.1)') 
     2     cntall(i,4),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
        write(*,'(/a,i6/a,i6)') 
     2    '       No. trait(+) marker(-) =',nuntyp,
     3    '       No. trait(+) marker(+) =',(nca+nco)/2
        if (typ.eq.1) then
          write(*,'(a,3(3x,f6.4))') 
     &      '                Fis, Fit, Fst =',fis, fit, fst
        end if
        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 =',asyp
      end if
C
C if founders only, or no cases or no controls or iter=0, then
C Monte-Carlo procedure superfluous
C
      it=0
      tailp=0
      if (assfnd .or. nca.eq.0 .or. nco.eq.0 .or. iter.eq.0) then
        pval=1.0d0
      else
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
   49   continue
        if (it.eq.iter .or. tailp.eq.mincnt) goto 50
          it=it+1
          do 52 j=1,ncats  
          do 52 k=1,3
            cntall(j,k)=0
   52     continue
          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)
            if (typ.eq.1) then
              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
            else
              do 66 i=1,num
              if (.not.untyped(i).and.(aff(i).eq.1.or.aff(i).eq.2)) then
                gtp=clcpos(set(i,1),set(i,2))
                cntall(gtp,aff(i))=cntall(gtp,aff(i))+1
              endif
   66         continue
            end if
          goto 55
   70     continue

          do 80 i=1,ncats  
            cntall(i,3)=cntall(i,1)+cntall(i,2)
   80     continue
          chisq=twobyk(ncats,cntall,pexp)
          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
            do 85 i=1,ncats
              write(*,'(i8,2(2x,i5,1x,a1,f3.2,a1),i8)') 
     2          cntall(i,4),cntall(i,2),'(',
     3          float(cntall(i,2))/float(nca),')',cntall(i,1),'(',
     4          float(cntall(i,1))/float(nco),')',cntall(i,3)
   85        continue
          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)
      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
        call phist(asyp,pval,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,1x,2a,1x,a)')
     2    locnam, (nca+nco)/2, df+1, ochisq, asyp, pval, it, 
     3    'AssX2-',ana,histo
      end if
      return
      end
C end-of-doassoc
C
C Pearson chi-sq for 2xK table (uses only cntall(,1-3))
C
      double precision function twobyk(nallele,cntall,pexp)
      integer MAXALL,MAXG
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2)
      integer nallele, cntall(MAXG,4)
      double precision pexp
      integer i
      double precision num1,num2, den1, den2
      twobyk=0.0d0
      if (pexp.eq.0.0d0 .or. pexp.eq.1.0d0) return
      do 10 i=1,nallele
      if (cntall(i,3).gt.0) then
        den2=pexp*dfloat(cntall(i,3))
        den1=dfloat(cntall(i,3))-den2
        num2=dfloat(cntall(i,2))-den2
        num1=dfloat(cntall(i,1))-den1
        twobyk=twobyk+(num1*num1)/den1+(num2*num2)/den2
      end if
   10 continue
      return
      end
C end-of-twobyk
C
C Test the 4 possible unions of gametes 1 2 3 4 -> 13 14 23 24 
C if typ=0 return both parental contributions, else 1=pat, 2=mat
C
      subroutine trans(pg1,pg2,mg1,mg2,cg1,cg2,tr1,tr2,nt1,nt2,typ)
      integer MISS
      parameter(MISS=-9999)
      integer pg1,pg2,mg1,mg2,cg1,cg2,tr1,tr2,nt1,nt2,typ
      real random
      tr1=MISS
      tr2=MISS
      nt1=MISS
      nt2=MISS
      if ((pg1.eq.MISS).and.(mg1.ne.MISS).and.
     2    .not.((mg1.eq.cg1).and.(mg2.eq.cg2)) 
     3   .and.((mg1.eq.cg1).or.(mg1.eq.cg2))) then
        tr1=mg1
        nt1=mg2
        tr2=MISS
        nt2=MISS
      elseif((pg1.eq.MISS).and.(mg1.ne.MISS)
     2       .and..not.((mg1.eq.cg1).and.(mg2.eq.cg2)) 
     3       .and.((mg2.eq.cg1).or.(mg2.eq.cg2))) then 
        tr1=mg2
        nt1=mg1
        tr2=MISS
        nt2=MISS
      elseif((pg1.ne.MISS).and.(mg1.eq.MISS)
     2        .and..not.((pg1.eq.cg1).and.(pg2.eq.cg2))  
     3        .and.((pg1.eq.cg1).or.(pg1.eq.cg2))) then
        tr1=MISS
        nt1=MISS
        tr2=pg1
        nt2=pg2
      elseif((pg1.ne.MISS).and.(mg1.eq.MISS)
     2        .and..not.((pg1.eq.cg1).and.(pg2.eq.cg2))
     3        .and.((pg2.eq.cg1).or.(pg2.eq.cg2))) then
        tr1=MISS
        nt1=MISS
        tr2=pg2
        nt2=pg1
      elseif(pg1.eq.mg1 .and. pg2.eq.mg2 .and. 
     &       pg1.eq.cg1 .and. pg2.eq.cg2) then
        if (typ.eq.1 .or. typ.eq.2) then
          tr1=MISS
          nt1=MISS
          tr2=MISS
          nt2=MISS
        else if (random().gt.0.5) then
          tr1=mg1
          nt1=mg2
          tr2=pg2
          nt2=pg1
        else
          tr1=mg2
          nt1=mg1
          tr2=pg1
          nt2=pg2
        end if
      elseif(((pg1.eq.cg1).and.(mg1.eq.cg2))
     2        .or.((pg1.eq.cg2).and.(mg1.eq.cg1))) then
        tr1=mg1
        nt1=mg2
        tr2=pg1
        nt2=pg2
      elseif(((pg1.eq.cg1).and.(mg2.eq.cg2))
     2        .or.((pg1.eq.cg2).and.(mg2.eq.cg1))) then
        tr2=pg1
        nt2=pg2
        tr1=mg2
        nt1=mg1
      elseif(((pg2.eq.cg1).and.(mg1.eq.cg2))
     2        .or.((pg2.eq.cg2).and.(mg1.eq.cg1))) then
       tr2=pg2
       nt2=pg1
       tr1=mg1
       nt1=mg2
      elseif(((pg2.eq.cg1).and.(mg2.eq.cg2))
     2        .or.((pg2.eq.cg2).and.(mg2.eq.cg1))) then
       tr2=pg2
       nt2=pg1
       tr1=mg2
       nt1=mg1
      end if
C check to see which parental contribution to retain
      if (typ.eq.1) then
        tr2=MISS
        nt2=MISS
      elseif (typ.eq.2) then
        tr1=MISS
        nt1=MISS
      end if
      return
      end
C end-of-trans
C
C Transmission of X-linked marker to a male
      subroutine xtrans(mg1,mg2,cg1,cg2,tr1,tr2, nt1, nt2)
      integer MISS
      parameter(MISS=-9999)
      integer mg1,mg2,cg1,cg2,tr1,tr2,nt1,nt2
      tr1=MISS
      nt1=MISS
      tr2=MISS
      nt2=MISS
      if (mg1.ne.MISS) then 
        if ((mg1.eq.cg1).or.(mg1.eq.cg2)) then
          tr1=mg1
          nt1=mg2
        else if ((mg2.eq.cg1).or.(mg2.eq.cg2)) then 
          tr1=mg2
          nt1=mg1
        end if
      end if
      return
      end
C end-of-xtrans
C
C Increment counts of transmitted and nontransmitted alleles: parentwise
C
      subroutine incpo(tr,nt,nall,cntall)
      integer MAXALL,MAXG,MISS
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MISS=-9999)
      integer tr,nt,nall,cntall(MAXG,4)
      integer i,j,a1,a2
      logical trans
      if (tr.eq.MISS.or.nt.eq.MISS.or.tr.eq.nt) return
      if (tr.le.nt) then
        trans=.true.
        a1=tr
        a2=nt
      else
        trans=.false.
        a1=nt
        a2=tr
      end if
      i=0
    5 continue
        i=i+1
      if (i.le.nall .and. (a1.gt.cntall(i,1).or.
     &    (a1.eq.cntall(i,1).and.a2.gt.cntall(i,2)))) goto 5
      if (i.le.nall .and. cntall(i,1).eq.a1.and.cntall(i,2).eq.a2) then
        if (trans) then
          cntall(i,3)=cntall(i,3)+1
        else
          cntall(i,4)=cntall(i,4)+1
        end if
      else
        do 20 j=nall,i,-1
        do 20 k=1,4
   20     cntall(j+1,k)=cntall(j,k)
        cntall(i,1)=a1
        cntall(i,2)=a2
        if(trans) then
          cntall(i,3)=1
          cntall(i,4)=0
        else
          cntall(i,3)=0
          cntall(i,4)=1
        end if
        nall=nall+1
      end if
      return
      end
C end-of-incpo
C
C Increment counts of transmitted and expected genotypes
C Revised after reading Thomas 1999
C
      subroutine incr(tr1,tr2,nt1,nt2,ngcount,gcount)
      integer MAXALL,MAXG,MISS
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2,MISS=-9999)
      integer tr1,tr2,nt1,nt2,ngcount,gcount(MAXG,4)
C only use cases both parents typed
      if (nt1.eq.MISS .or. nt2.eq.MISS) return
C case
      call insgen(tr1,tr2,ngcount,gcount,3,1)
C 4 pseudo-sibs for control distribution
      call insgen(tr1,tr2,ngcount,gcount,4,1)
      call insgen(tr1,nt2,ngcount,gcount,4,1)
      call insgen(nt1,tr2,ngcount,gcount,4,1)
      call insgen(nt1,nt2,ngcount,gcount,4,1)
      return
      end
C end-of-incr
C
C update counts of genotypes or haplotypes for cases or controls -- 
C binary search and insertion sort
C
      subroutine insgen(a1,a2,ngcount,gcount,type,haplo)
      integer MAXALL, MAXG 
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2)
      integer a1,a2,haplo,ngcount,gcount(MAXG,4),type
      integer g1,g2,hi,j,k,lo,pos
C if genotype, order by allele size rather than parent of origin
      if (haplo.eq.2 .or. a1.le.a2) then
        g1=a1
        g2=a2
      else
        g1=a2
        g2=a1
      end if
      pos=1
      hi=ngcount
      lo=1
    1 continue 
      if (hi.lt.lo) goto 5
        pos=(hi+lo)/2
        if (g1.gt.gcount(pos,1) .or.
     &      (g1.eq.gcount(pos,1) .and. g2.gt.gcount(pos,2))) then
          lo=pos+1
        elseif (g1.lt.gcount(pos,1).or.
     &      (g1.eq.gcount(pos,1) .and. g2.lt.gcount(pos,2))) then
          hi=pos-1
        else
          gcount(pos,type)=gcount(pos,type)+1
          return
        end if
      goto 1
    5 continue
C else create new category
      do 50 j=ngcount,pos,-1
      do 50 k=1,4
        gcount(j+1,k)=gcount(j,k)
   50 continue
      gcount(lo,1)=g1
      gcount(lo,2)=g2
      gcount(lo,3)=0
      gcount(lo,4)=0        
      gcount(lo,type)=1
      ngcount=ngcount+1
      return
      end
C end-of-insgen
C
C Monte-Carlo approach to various TDTs
C
      subroutine dotdt(wrk,wrk2,trait,locnam,gene,iter,mincnt,use2,typ,
     2             cutoff,gt,thresh,pedigree,actset,num,nfound,id,fa,mo,
     3             sex,locus, numloc, numal, name, untyped, set,
     4             nallele,cntall,ngcount,gcount,plevel)
      integer MAXALL, MAXG, MAXSIZ, MAXLOC, MISS, KNOWN
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2, 
     &          MAXSIZ=1000, MAXLOC=120, MISS=-9999, KNOWN=0)
      integer cutoff,gene,iter,mincnt,plevel,trait,typ,use2,wrk,wrk2
      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), set(MAXSIZ,2)
      real locus(MAXSIZ,MAXLOC)
C allele frequencies structure
      integer numal, name(MAXALL)
C Genotype counts: allele1,allele2, number transmitted, number not trans
      integer nallele,cntall(MAXG,4), ngcount,gcount(MAXG,4)
C
      integer cg1,cg2,pg1,pg2,mg1,mg2,tr1,tr2,nt1,nt2
      logical last, untyped(MAXSIZ)
      integer alltr,allnt,df,gdf,gen2,i,it,j,k,mxiter,ntest,tailp,tot
      integer aff(MAXSIZ),naff,prob,probandi
      character*3 histo
      double precision celltdt, tdt, otdt, gtdt, mgtdt, mcnem, pval
      double precision asyp, bestm, bestp, ewens, ftdev
      character*7 gtp, gtp2
C functions 
      double precision binp, bonf, chip, clcchi, clcmcn, ln
      real isaff,random
      logical tdtuse
C
      df=0
      ewens=0.0d0
      gdf=0
      gen2=gene+1
      nallele=0
      ngcount=0
      ntest=0
      mgtdt=0.0d0
      probandi=0
      tot=0
      tdt=0.0d0
      do 2 i=1,MAXG
      do 2 j=1,4
        gcount(i,j)=0
        cntall(i,j)=0
    2 continue
      last=.false.
      rewind(wrk)
C
C If high print level, then list transmitted and nontransmitted alleles
C for each informative proband
C
      if (plevel.gt.1) then
        write(*,'(a/a)') 'Informative Child   Trans    Not Tr ',
     &                   'Pedigree  ID        Mat Pat  Mat Pat'
      end if
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
         naff=0
         do 11 i=1,nfound
           untyped(i)=.false.
           if (locus(i,gene).lt.KNOWN) untyped(i)=.true.
   11    continue
         do 12 i=nfound+1,num
           untyped(i)=.false.
           if (locus(i,gene).lt.KNOWN) then
             untyped(i)=.true.
           else if (isaff(locus(i,trait),thresh,gt).eq.2.0 .and. 
     &              tdtuse(i,gene,naff,fa,mo,locus,use2)) then
C
C nonfounder affected & typed & 1 or 2 parents heterozygous at marker
C 
             naff=naff+1
             aff(naff)=i
             pg1=MISS
             pg2=MISS
             if (locus(fa(i),gene).gt.KNOWN) then
               pg1=int(locus(fa(i),gene))
               pg2=int(locus(fa(i),gen2))
             end if
             mg1=MISS
             mg2=MISS
             if (locus(mo(i),gene).gt.KNOWN) then
               mg1=int(locus(mo(i),gene))
               mg2=int(locus(mo(i),gen2))
             end if
             cg1=int(locus(i,gene))
             cg2=int(locus(i,gen2))
             call trans(pg1,pg2,mg1,mg2,cg1,cg2,tr1,tr2,nt1,nt2,typ)
             if (plevel.gt.1) then
               call wrgtp(tr1,tr2,gtp,2)
               call wrgtp(nt1,nt2,gtp2,2)
               write(*,'(a10,a8,2(1x,a8))') pedigree,id(i),gtp,gtp2
             end if
             call incpo(tr1,nt1,nallele,cntall)
             call incpo(tr2,nt2,nallele,cntall)
             call incr(tr1,tr2,nt1,nt2,ngcount,gcount)
           end if
   12    continue
         probandi=probandi+naff
         if (naff.gt.0) then
           do 14 i=1,num   
             set(i,1)=MISS
             set(i,2)=MISS
             if (locus(i,gene).gt.KNOWN) then
               set(i,1)=int(abs(locus(i,gene)))
               set(i,2)=int(abs(locus(i,gen2)))
             end if
   14      continue
           write(wrk2) naff,(aff(i),i=1,naff),num,nfound,
     &       (fa(i),mo(i),untyped(i),set(i,1),set(i,2),i=1,num) 
         end if
       goto 10
   20  continue
C
      if (plevel.gt.1) then
        write(*,*)
      end if
      if (plevel.gt.0) then
        write(*,'(/a,i3)') 'Number of informative probands: ',probandi
C
        write(*,'(/3a/a/a)') 
     2   '  - Allele by Allele TDT:"',locnam,'" -',
     3   '  Allele   Trans  Not Tr   TDT   P-value',
     4   '  --------------------------------------'
      end if
      bestm=0.0d0
      bestp=1.0d0
      do 215 i=1,numal
        alltr=0
        allnt=0
        do 220 j=1,nallele
          if (cntall(j,1).eq.name(i)) then
            alltr=alltr+cntall(j,3)
            allnt=allnt+cntall(j,4)
          elseif (cntall(j,2).eq.name(i)) then
            alltr=alltr+cntall(j,4)
            allnt=allnt+cntall(j,3)
          end if
  220   continue
        if ((alltr+allnt).gt.cutoff) then
          ntest=ntest+1
          mcnem=clcmcn(alltr,allnt)
          ewens=ewens+mcnem
          pval=binp(dfloat(alltr),dfloat(allnt))
          if (pval.lt.bestp) then
            bestp=pval
            bestm=mcnem
          end if
          if (plevel.gt.0) then
            write(*,'(3i8,f6.1,4x,f6.4)') 
     &        name(i),alltr,allnt,mcnem,pval 
          end if
        end if
  215 continue
      if (ntest.gt.1) ewens=dfloat(ntest-1)*ewens/dfloat(ntest)

      if (plevel.gt.0) then
        if (cutoff.gt.0)
     &     write(*,'(/a,i4)') 'Not using rows with totals   =<',cutoff
        if (ntest.gt.0) then
          write(*,'(/a,i4,3(/a,3x,f8.6)/)') 
     2    'No. of alleles used  = ',ntest,
     3    'Bonferroni corr. 5%  = ',bonf(ntest-1,0.05d0),
     4    'Bonferroni corr. 1%  = ',bonf(ntest-1,0.01d0),
     5    'Bonferroni corr. 0.1%= ',bonf(ntest-1,0.001d0)
        else
          write(*,'(a)') 'No alleles meet inclusion criteria'
        end if
      else
        if (ntest.gt.0) asyp=min(1.0d0,(ntest-1)*bestp)
        call phist(asyp,asyp,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     2    locnam, probandi, ntest, bestm, asyp, asyp,
     3    0, 'TDT-Best ', histo
      end if
C
      alltr=0
      allnt=0
      if (plevel.gt.0) then
        write(*,'(/a/a/a)') 
     2    '  -------- Global Allelic TDT --------',
     3    '   All 1   All 2    Tr=1    Tr=2   TDT',
     4    '  ------------------------------------'
      end if
      do 15 i=1,nallele
        celltdt=0.0d0
        alltr=alltr+cntall(i,3)
        allnt=allnt+cntall(i,4)
        if ((cntall(i,3)+cntall(i,4)).gt.cutoff) then
          celltdt=dfloat(cntall(i,3)-cntall(i,4))**2
     &            /dfloat(cntall(i,3)+cntall(i,4))
          tdt=tdt+celltdt
          df=df+1
        end if
        if (plevel.gt.0) then
          write(*,'(4i8,f6.1)') 
     &       cntall(i,1),cntall(i,2),cntall(i,3),cntall(i,4),celltdt
        end if
   15 continue
      tot=alltr+allnt
      asyp=1.0d0
      if (df.gt.0) asyp=chip(tdt,df)

      if (plevel.gt.0) then
        write(*,'(/a,f6.1)') 'Allelic TDT Pearson chi-square=',tdt
        if (cutoff.gt.0) then
           write(*,'(a,i4)') 'Not using rows with totals   =<',cutoff
        end if
        write(*,'(12x,a,i4)') 'Degrees of freedom=',df
        write(*,'(23x,a,3x,f6.4)') 'P-value=', asyp
      end if
      if (iter.gt.0 .and. tot.gt.0) then
        mxiter=10*iter
        call shuffle(nallele,cntall,tot,cutoff,tdt,mxiter,mincnt,
     &               pval)
      else
        mxiter=0
        pval=1.0d0
      end if
      if (plevel.gt.0) then
        write(*,'(a,i7,a,3x,f6.4)') 
     &   'Empiric P-value (',mxiter,' iter)=',pval
        write(*,'(/a,f6.1)') '  Ewens allelic TDT chi-square=',ewens
        write(*,'(12x,a,i4)') 'Degrees of freedom=',ntest-1
        write(*,'(23x,a,3x,f6.4)') 'P-value=',chip(ewens,ntest-1)
        write(*,'(/a/a/a)') 
     2    '  ----- Genotypic Transmission Test ------',
     3    '       Genotype     Trans  Expected   Dev',
     4    '  ----------------------------------------'
      else
        call phist(asyp,pval,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     2    locnam, probandi, df, tdt, asyp, pval,mxiter,'TDT-All  ',histo
        asyp=1.0d0
        df=max(0,df-1)
        if (df.gt.0) asyp=chip(ewens,df)
        call phist(asyp,asyp,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     2    locnam, probandi, df, ewens, asyp, asyp, 0, 
     3    'TDT-Ewens',histo
      end if

      otdt=0.0d0
      do 225 i=1,ngcount
        if (gcount(i,3).gt.cutoff) then
          gdf=gdf+1
          if (gcount(i,4).gt.cutoff) then
            otdt=otdt+dfloat(gcount(i,3))*
     &           ln(dfloat(4*gcount(i,3))/dfloat(gcount(i,4)))
          end if
        end if    
        call wrgtp(gcount(i,1),gcount(i,2),gtp,1)
        if (plevel.gt.0) then
          write(*,'(8x,a7,1x,i8,1x,f9.1,1x,f6.1)') 
     2     gtp,gcount(i,3),0.25d0*dfloat(gcount(i,4)),
     3     ftdev(dfloat(gcount(i,3)),0.25d0*dfloat(gcount(i,4)))
        end if
  225 continue
      otdt=otdt+otdt
      gdf=max(gdf-1,1)
      asyp=chip(otdt,gdf)
C
C Monte-Carlo only if iter>0
C
      it=0
      tailp=0
      if (iter.eq.0 .or. tot.eq.0) then
        pval=1.0d0
      else
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
   49   continue
        if (it.eq.iter .or. tailp.eq. mincnt) goto 50
          it=it+1
          do 52 j=1,ngcount
          do 52 k=1,4
            gcount(j,k)=0
   52     continue        
          ngcount=0
          rewind(wrk2)

   55     continue
            read(wrk2,end=70) naff,(aff(i),i=1,naff),num,nfound,
     &        (fa(i),mo(i),untyped(i),set(i,1),set(i,2),i=1,num) 
            call csimped(num,nfound,fa,mo,untyped,set)
            do 60 i=1,naff
              prob=aff(i)
              pg1=set(fa(prob),1)
              pg2=set(fa(prob),2)
              mg1=set(mo(prob),1)
              mg2=set(mo(prob),2)
              cg1=set(prob,1)
              cg2=set(prob,2)
              call trans(pg1,pg2,mg1,mg2,cg1,cg2,tr1,tr2,nt1,nt2,typ)
              call incr(tr1,tr2,nt1,nt2,ngcount,gcount)
   60       continue
          goto 55
   70     continue
          gtdt=clcchi(ngcount,gcount,cutoff)
          mgtdt=mgtdt+gtdt
          if (gtdt.gt.otdt .or. (gtdt.eq.otdt .and. 
     2        random().gt.0.5d0))  then
            tailp=tailp+1
          end if
          if (plevel.gt.1) then
            write(*,'(/a,i4,a,f6.1)') 
     &       'Pseudosample ',it,': gX2 =',gtdt
            do 325 i=1,ngcount
              call wrgtp(gcount(i,1),gcount(i,2),gtp,1)
  325         write(*,'(8x,a7,1x,2i8)') 
     &          gtp,gcount(i,3),gcount(i,4)
          end if
          goto 49
   50   continue
        if (tailp.lt.mincnt) then
          tailp=tailp+1
          it=it+1
        end if
        mgtdt=mgtdt/dfloat(it)
        pval=dfloat(tailp)/dfloat(it)
      end if
      if (plevel.gt.0) then
        write(*,'(/a,f6.1/a,i4)')
     2    'Genotypic Transmission Chi-sq =',otdt,
     3    '   Nominal degrees of freedom =',gdf
        if (cutoff.gt.0) then
          write(*,'(a,i4)') 'Not using rows with totals   =<',cutoff
        end if
        write(*,'(14x,a,3x,f6.4)') 'Nominal P-value =',asyp
        write(*,'(6x,a,i4,a,i4,a,f6.4,a/a,f6.1)')
     2    'Equalled or exceeded by =',tailp,'/',it,
     3    ' simulated values (',pval,')',
     4    'Mean of simulated chi-squares =',mgtdt
      else
        call phist(asyp,pval,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     &    locnam, probandi, gdf, otdt, asyp, pval, it,'TDT-Gtp  ',histo
      end if
      return
      end
C end-of-dotdt
C
C test if useful for TDT
C
      logical function tdtuse(idx,gene,naff,fa,mo,locus,use2)
      integer MAXSIZ, MAXLOC, KNOWN
      parameter(MAXSIZ=1000, MAXLOC=120, KNOWN=0)
      integer gene,idx, naff, use2
C pedigree structure
      integer fa(MAXSIZ),mo(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer gen2

      gen2=gene+1
      tdtuse=.false.

C both parents untyped
      if (locus(fa(idx),gene).lt.KNOWN .and. 
     &    locus(mo(idx),gene).lt.KNOWN) then
        return
C only using one proband per family
      elseif (naff.gt.0 .and. use2.gt.2) then
        return
C one parent untyped and the other homozygous or same genotype as index
      elseif (locus(mo(idx),gene).lt.KNOWN .and. (use2.gt.1 .or.
     2        ((locus(fa(idx),gene).eq.locus(fa(idx),gen2) .or. 
     3        (locus(idx,gene).eq.locus(fa(idx),gene)
     4        .and. locus(idx,gen2).eq.locus(fa(idx),gen2)))))) then
        return
      elseif (locus(fa(idx),gene).lt.KNOWN .and. (use2.gt.1 .or.
     2        ((locus(mo(idx),gene).eq.locus(mo(idx),gen2) .or.
     3        (locus(idx,gene).eq.locus(mo(idx),gene)
     4        .and. locus(idx,gen2).eq.locus(mo(idx),gen2)))))) then
        return
C both parents homozygous 
      elseif (locus(fa(idx),gene).eq.locus(fa(idx),gen2) .and. 
     &        locus(mo(idx),gene).eq.locus(mo(idx),gen2)) then 
        return
C both parents same genotype as index
C     elseif (locus(idx,gene).eq.locus(fa(idx),gene) .and. 
C    2        locus(idx,gen2).eq.locus(fa(idx),gen2) .and. 
C    3        locus(idx,gene).eq.locus(mo(idx),gene) .and. 
C    4        locus(idx,gen2).eq.locus(mo(idx),gen2)) then
C       return
      end if
      tdtuse=.true.
      return
      end
C end-of-tdtuse
C
C randomization test for allelic TDT -- shuffle table ITER times 
C using TOT swaps per shuffle
C
      subroutine shuffle(nallele,cntall,tot,cutoff,tdt,mxiter,mincnt,
     &                   pvalue)
      integer MAXALL, MAXG
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2)
      integer mxiter, mincnt
      double precision pvalue, tdt
C Genotype counts: all1, all2, #all1 trans, #all2 trans
      integer nallele,cntall(MAXG,4),tot,cutoff
C local variables
      integer toc,cum,oldcum,row,col
      integer i,it,swap,tailp
      double precision simtdt
C functions
      double precision clctdt
      integer irandom
      real random
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
      it=0
      tailp=0
    5 continue
      if (it.eq.mxiter .or. tailp.eq.mincnt) goto 10
        it=it+1
        do 20 i=1,tot
          swap=irandom(1,tot)
          oldcum=0
          do 25 row=1,nallele
          do 25 col=3,4
          if (cntall(row,col).gt.0) then
            cum=oldcum+cntall(row,col)
            if  (swap.le.cum .and. swap.gt.oldcum) 
     &      then
              toc=4
              if (col.eq.4) toc=3
              goto 26
            end if
            oldcum=cum
          end if
   25     continue
   26     continue
          cntall(row,col)=cntall(row,col)-1
          cntall(row,toc)=cntall(row,toc)+1
   20   continue
        simtdt=clctdt(nallele,cntall,cutoff)
        if (simtdt.gt.tdt .or. (simtdt.eq.tdt .and. 
     2      random().gt.0.5))  then
          tailp=tailp+1
        end if
      goto 5
   10 continue
      if (tailp.lt.mincnt) then
        tailp=tailp+1
        it=it+1
      end if
      mxiter=it
      pvalue=dfloat(tailp)/dfloat(mxiter)
      return
      end
C end-of-shuffle
C
C calculate symmetry pearson chi-square
C
      double precision function clctdt(ngcount,gcount,cutoff)
C
C Genotype counts
C genotype allele1,allele2, number transmitted, number not trans
      integer MAXALL,MAXG
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2)
      integer ngcount,gcount(MAXG,4),cutoff
      integer j
      clctdt=0.0d0
      do 10 j=1,ngcount
      if ((gcount(j,3)+gcount(j,4)).gt.cutoff) then
        clctdt=clctdt+dfloat(gcount(j,3)-gcount(j,4))**2
     &         /dfloat(gcount(j,3)+gcount(j,4))
      end if
   10 continue
      return
      end
C end-of-clctdt
C
C calculate g.o.f. LR chi-square
C
      double precision function clcchi(ngcount,gcount,cutoff)
C
C Genotype counts
C genotype allele1,allele2, number transmitted, 
C expected number based on parental genotypes
C
      integer MAXALL,MAXG
      parameter(MAXALL=60,MAXG=MAXALL*(MAXALL+1)/2)
      integer ngcount,gcount(MAXG,4),cutoff
      integer j
      clcchi=0.0d0
      do 10 j=1,ngcount
      if (gcount(j,3).gt.cutoff .and. gcount(j,4).gt.cutoff) then
        clcchi=clcchi+dfloat(gcount(j,3))*
     &         log(dfloat(4*gcount(j,3))/dfloat(gcount(j,4)))
      end if
   10 continue
      clcchi=clcchi+clcchi
      return
      end
C end-of-clcchi
C
C Approach of Schaid and Sommer (1993), amplified by Knapp et al (1995)
C
C MM x MM   MM x MN   MM x NN   MN x MN    MN x NN    NN x NN    
C   MM      MM   MN     MN      MM MN NN   MN   NN      NN
C   n1      n2   n3     n4      n5 n6 n7   n8   n9      n10
C
C a=4*n1 + 3*n2 + 3*n3 + 2*n4 + 2*n5 + 2*n6 + 2*n7 + n8 + n9
C b=n2 + n3 + 2*n4 + 2*n5 + 2*n6 + 2*n7 + 3*n8 + 3*n9 + 4*n10
C c=n1 + n2 + n5
C d=n3 + n4 + n6 + n8
C
C providing n-c-d!=0 and a-2c-d!=0 then
C
C p=(a-2*c-d)/2n
C r1= (1-p)*d/(2*p*(n-c-d))
C r2= (1-p)^2 c/(p^2*(n-c-d))
C
C Here, actually done as the log-linear model, as the closed form
C standard error formulae are ugly
C
C
      subroutine nucseg(wrk,trait,gene,candal,x,r,b,cov,pedigree,actset,
     2             num,nfound,id,fa,mo,sex,locus, numloc, key, plevel)
      integer MAXCOV, MAXLOC, MAXIBD, MAXSIZ, MAXTER, KNOWN
      parameter(MAXSIZ=1000, MAXLOC=120, KNOWN=0,
     3          MAXIBD=1000, MAXTER=MAXIBD/2, 
     4          MAXCOV=MAXTER*(MAXTER+1)/2 )
      integer gene,plevel,trait,wrk
      real candal
C pedigree structure
      character*10 pedigree
      integer sex(MAXSIZ)
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C work arrays for log-linear modelling
      double precision x(MAXTER), r(MAXCOV), b(MAXTER), cov(MAXCOV)
      integer key(MAXSIZ)
C local variables
      real count(16), cpgmod(40), hwemod(64)
      integer gen2, i, naff, pos
      character*7 gtp0, gtp1, gtp2
      logical last
      double precision lik0, lik1, p, p0, q, q0, r0, r1, r2,
     &                 e1,e2,e3,e4,e5,e6, se1, se2
C
C functions 
      double precision chip
C
      data hwemod / 1.0,4.0,0.0,1.0,1.0,3.0,0.0,1.0,1.0,3.0,0.0,1.0,
     2              1.0,3.0,1.0,0.0,1.0,3.0,1.0,0.0,1.0,2.0,1.0,0.0,
     3              1.0,2.0,1.0,0.0,1.0,2.0,0.0,1.0,1.0,2.0,1.0,0.0,
     4              1.0,2.0,1.0,0.0,1.0,2.0,0.0,0.0,1.0,1.0,1.0,0.0,
     5              1.0,1.0,1.0,0.0,1.0,1.0,0.0,0.0,1.0,1.0,0.0,0.0,
     6              1.0,0.0,0.0,0.0 /
      data cpgmod / 
     2 1.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,1.0,0.0,
     3 0.0,1.0,0.0,0.0,1.0,0.0,1.0,0.0,1.0,0.0,
     4 0.0,1.0,0.0,1.0,0.0,0.0,1.0,0.0,0.0,0.0,
     5 0.0,0.0,1.0,1.0,0.0,0.0,0.0,1.0,0.0,0.0 /
      gen2=gene+1
      naff=0
      do 1 i=1,10
        key(i)=0
    1 continue  
      if (plevel.gt.1) then
        write(*,'(/a)') 'Pedigree   ID         Child   Father  Mother'
      end if
      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=nfound+1,num
         if (locus(i,trait).eq.2.0 .and.
     2     locus(i,gene).gt.KNOWN .and. locus(fa(i),gene).gt.KNOWN .and.
     3     locus(mo(i),gene).gt.KNOWN)  then
           naff=naff+1
           nfa=0
           nmo=0
           nch=0
           if (locus(i,gene).eq.candal) nch=nch+1
           if (locus(i,gen2).eq.candal) nch=nch+1
           if (locus(fa(i),gene).eq.candal) nfa=nfa+1
           if (locus(fa(i),gen2).eq.candal) nfa=nfa+1
           if (locus(mo(i),gene).eq.candal) nmo=nmo+1
           if (locus(mo(i),gen2).eq.candal) nmo=nmo+1
           if (nmo.eq.1 .and. nfa.eq.1) then
             pos=7-nch
           else if ((nfa+nmo).gt.1) then
             pos=7-nfa-nmo-nch
           else
             pos=10-nfa-nmo-nch
           end if
           key(pos)=key(pos)+1
           if (plevel.gt.1) then
             write(*,'(a10,1x,a8,3(1x,i3,1x,i3))') pedigree,id(i),
     2         int(locus(i,gene)), int(locus(i,gen2)), 
     3         int(locus(fa(i),gene)), int(locus(fa(i),gen2)), 
     4         int(locus(mo(i),gene)), int(locus(mo(i),gen2)) 
           end if
         end if
   12    continue
       goto 10
   20 continue
      count(1)=float(key(1))
      count(2)=0.5*float(key(2))
      count(3)=count(2)
      count(4)=0.5*float(key(3))
      count(5)=count(4)
      count(6)=0.5*float(key(4))
      count(7)=count(6)
      count(8)=float(key(5))
      count(9)=0.5*float(key(6))
      count(10)=count(9)
      count(11)=float(key(7))
      count(12)=0.5*float(key(8))
      count(13)=count(12)
      count(14)=0.5*float(key(9))
      count(15)=count(14)
      count(16)=float(key(10))

      call loglin(16,4,2,count,hwemod,x,r,b,cov,lik0)
      p0=exp(b(2))
      p0=p0/(1.0d0+p0)
      q0=1.0d0-p0
      call loglin(16,4,4,count,hwemod,x,r,b,cov,lik1)
      p=exp(b(2))
      p=p/(1.0d0+p)
      q=1.0d0-p
      r1=b(3)
      r2=b(4)
      r0=p*p*exp(r2)+2*p*q*exp(r1)+q*q
      se1=1.96d0*sqrt(cov(6))
      se2=1.96d0*sqrt(cov(10))
      lik1=lik0-lik1
      lik1=lik1+lik1
C
      e1=p0*p0*p0*p0*dfloat(naff)
      e2=4*p0*q0*p0*p0*dfloat(naff)
      e3=2*p0*p0*q0*q0*dfloat(naff)
      e4=4*p0*q0*p0*q0*dfloat(naff)
      e5=4*p0*q0*q0*q0*dfloat(naff)
      e6=q*q*q*q*dfloat(naff)
      call wrgtp(int(candal),int(candal),gtp2,1)
      call wrgtp(int(candal),0,gtp1,1)
      call wrgtp(0,0,gtp0,1)

      write(*,'(/a/6x,a,9x,a,3(1x,a)/a)') 
     2  '------------------------------------------------------------',
     3  'Mating','Total Expected', gtp2, gtp1, gtp0,
     4  '------------------------------------------------------------' 
      write(*,50) gtp2,' x ',gtp2, key(1),e1,key(1),'x  ','x  ',
     2  gtp2,' x ',gtp1, key(2)+key(3),e2,key(2),key(3),'x  ',
     3  gtp2,' x ',gtp0, key(4),e3,'x  ',key(4),'x  ',
     4  gtp1,' x ',gtp1, key(5)+key(6)+key(7),e4,key(5),key(6),key(7),
     5  gtp1,' x ',gtp0, key(8)+key(9),e5,'x  ',key(8),key(9),
     6  gtp0,' x ',gtp0, key(10),e6,'x  ','x  ',key(10) 
   50 format(3a,i9,f9.1,(1x,i5,2x),2a8  /3a,i9,f9.1,2(1x,i5,2x),a8/
     2       3a,i9,f9.1,a8,(1x,i5,2x),a8/3a,i9,f9.1,3(1x,i5,2x)/
     3       3a,i9,f9.1,a8,2(1x,i5,2x)  /3a,i9,f9.1,2a8,1x,i5)
      write(*,'(a//a,i3,a,f5.3/a,i5)')  
     2  '------------------------------------------------------------',
     3  'Freq of ',int(candal),' allele   =     ',p,
     4  'N affected children  = ',naff 
      write(*,'(/a,f8.2,a,f5.3,a,2(/3(a,f8.2),a)/a,f8.2)') 
     2  'HWE Chi-square (2 df)= ',lik1,' (P=',chip(lik1,2),')',
     3  'Genotypic RR1 (f1)   = ',exp(r1),' (95%CI=',
     4     exp(r1-se1),' to ',exp(r1+se1),')',
     5  'Genotypic RR2 (f2)   = ',exp(r2),' (95%CI=',
     6     exp(r2-se2),' to ',exp(r2+se2),')',
     7  'Attributable risk    = ', (p*p*(exp(r2)-1.0d0)+
     8     2*p*q*(exp(r1)-1.0d0))/r0
C
C ML CPG test
C
      count(1)=float(key(2))
      count(2)=float(key(3))
      count(3)=float(key(5))
      count(4)=0.5*float(key(6))
      count(5)=count(4)
      count(6)=float(key(7))
      count(7)=float(key(8))
      count(8)=float(key(9))
      call loglin(8,5,3,count,cpgmod,x,r,b,cov,lik0)
      call loglin(8,5,5,count,cpgmod,x,r,b,cov,lik1)
      r1=b(4)
      r2=b(5)
      r0=p*p*exp(r2)+2*p*q*exp(r1)+q*q
      se1=1.96d0*sqrt(cov(10))
      se2=1.96d0*sqrt(cov(15))
      lik1=lik0-lik1
      lik1=lik1+lik1
      write(*,'(/a,f8.2,a,f5.3,a,2(/3(a,f8.2),a)/a,f8.2)') 
     2  'CPG Chi-sq    (2 df) = ',lik1,' (P=',chip(lik1,2),')',
     3  'Genotypic RR1 (f1)   = ',exp(r1),' (95%CI=',
     4     exp(r1-se1),' to ',exp(r1+se1),')',
     5  'Genotypic RR2 (f2)   = ',exp(r2),' (95%CI=',
     6     exp(r2-se1),' to ',exp(r2+se1),')',
     7  'Attributable risk    = ',(p*p*(exp(r2)-1.0d0)+
     8     2*p*q*(exp(r1)-1.0d0))/r0
C
      return
      end
C end-of-nucseg
C
C zero-trapped log
      double precision function ln(x)
      double precision x
      if (x.le.0.0d0) then
        ln=0.0d0
      else
        ln=log(x)
      end if
      return
      end
C end-of-ln
C
C perform sibship association permutation test
C
C Combines TDT with SDT: appropriate permutation set for each sibship
C
C If both parents genotyped, then each child can be drawn from 13,14,23,24
C If one or no parents genotyped, but may be reconstructed, then draw
C from mixture of obligate genotypes (those usable to reconstruct the missing
C parents) and 13,14,23,24.
C If cannot unequivocally reconstruct parental genotypes
C draw only from obligate (observed) genotypes among children
C
      subroutine rctdt(wrk,wrk2,trait,locnam,gene,iter,mincnt,gt,
     2             thresh,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3             numloc, numal,name,cntall,aff,set,x,
     4             mtrans,vtrans,plevel)
C
      integer KNOWN, MAXALL, MAXG, MAXSIZ, MAXLOC, MISS
      double precision EPS
      parameter(EPS=1.0d-6,KNOWN=0, MAXALL=60, 
     2          MAXG=MAXALL*(MAXALL+1)/2,MAXSIZ=1000, 
     3          MAXLOC=120, MISS=-9999)
      integer gene,iter,mincnt,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)
      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)
      double precision x(MAXALL),mtrans(MAXALL),vtrans(MAXG)
C local variables
      integer contrib,df,gen2,i,it,j,k,naff,nuntyp,pos,tailp
      integer currf, currm, fin, mg1, mg2, pg1,pg2, nfam, 
     &        parall, ptyped, partyp(4,3)
      logical last
      character*3 histo
      real casden, conden
      double precision asyp, bestz, chisq, obs, 
     &                 mchisq, ochisq, pval, vchisq
C functions
      integer getnam
      logical rctuse
      real isaff
      double precision chip
C
      df=-1
      gen2=gene+1
      nca=0
      nco=0
      nfam=0
      nuntyp=0
      parall=0
      do 1 i=1,4
        partyp(i,1)=0
        partyp(i,2)=0
        partyp(i,3)=0
    1 continue
      do 2 j=1,numal  
        mtrans(j)=0.0d0
        vtrans(j)=0.0d0
        do 2 k=1,3
          cntall(j,k)=0
    2 continue
      mchisq=0.0d0
      vchisq=0.0d0
      if (plevel.gt.1) then
        write(*,'(/a/a)') 
     2    '----- Sibships used for RC-TDT -----',
     3    'Pedigree   Father   Mother   Aff Tot'
      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) goto 5
C
C Full sibs
C
        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
            naff=0
            do 12 i=k+1,fin
            if (locus(i,gene).gt.KNOWN) then
              contrib=contrib+1
              set(contrib,1)=getnam(locus(i,gene),numal,name)
              set(contrib,2)=getnam(locus(i,gen2),numal,name)
              if (locus(i,trait).ne.MISS) then
                aff(contrib)=int(isaff(locus(i,trait),thresh,gt))
                naff=naff+aff(contrib)-1
              else
                nuntyp=nuntyp+1
              end if
            end if
   12       continue
C
C Skip if no usable individuals in this sibship
C
            if (contrib.gt.0 .and. naff.gt.0) then
              ptyped=1
              if (locus(currf,gene).gt.KNOWN) then
                ptyped=ptyped+1
                pg1=getnam(locus(currf,gene),numal,name)
                pg2=getnam(locus(currf,gen2),numal,name)
              else
                pg1=MISS
                pg2=MISS
              end if
              if (locus(currm,gene).gt.KNOWN) then
                ptyped=ptyped+2
                mg1=getnam(locus(currm,gene),numal,name)
                mg2=getnam(locus(currm,gen2),numal,name)
              else
                mg1=MISS
                mg2=MISS
              end if
              partyp(ptyped,1)=partyp(ptyped,1)+1
              call parimp(pg1,pg2,mg1,mg2,contrib,set,parall)
C
C Skip if family uninformative: need at least one heterozygote parent
C and if parental genotypes imputed, either affected and 
C unaffected offspring to permute, or more than two affected
C
              if (rctuse(pg1,pg2,mg1,mg2,ptyped,parall,contrib,naff))
     &        then
                partyp(ptyped,2)=partyp(ptyped,2)+1
                partyp(ptyped,3)=partyp(ptyped,3)+naff
                if (plevel.gt.1) then
                  write(*,'(a,2(1x,a),2(1x,i3))') 
     &              pedigree, id(currf), id(currm), naff, contrib
                end if
                nfam=nfam+1
                do 14 i=1,contrib
                if (aff(i).ne.MISS) 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
                end if
   14           continue
                write(wrk2) pg1,pg2,mg1,mg2,contrib,
     &                      (aff(i),set(i,1),set(i,2),i=1,contrib)
              end if
            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

      do 25 j=1,numal
        nco=nco+cntall(j,1)
        nca=nca+cntall(j,2)
        cntall(j,3)=cntall(j,1)+cntall(j,2)
        if (cntall(j,3).gt.0) df=df+1
   25 continue
C
C MC estimation of mean and variance
C
      it=0
      tailp=0
      if (iter.eq.0 .or. nca.eq.0 .or. nfam.lt.1) then
        asyp=1.0d0
        pval=1.0d0
      else
C
        do 50 it=1,iter
          call rctsim(wrk2,pg1,pg2,mg1,mg2,contrib,aff,set,numal,x)
          call dssp(numal,it,1,x,mtrans,vtrans)
   50   continue
        do 60 j=1, numal*(numal+1)/2
          vtrans(j)=vtrans(j)/dfloat(max(1,it-1))
   60   continue
C
C Sequential P-value simulation
C
        ochisq=0.0d0
        pos=0
        do 65 j=1, numal
          obs=dfloat(cntall(j,2))
          if (mtrans(j).gt.EPS .and. obs.gt.EPS) then
            ochisq=ochisq+obs*log(obs/mtrans(j))
          end if    
   65   continue

        it=0
   69   continue
        if (it.eq.iter .or. tailp.eq.mincnt) goto 70
          it=it+1
          call rctsim(wrk2,pg1,pg2,mg1,mg2,contrib,aff,set,numal,x)
          chisq=0.0d0
          do 75 j=1, numal
          if (mtrans(j).gt.EPS .and. x(j).gt.EPS) then
            chisq=chisq+x(j)*log(x(j)/mtrans(j))
          end if    
   75     continue
          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,': RC-TDT=',chisq
          end if
          goto 69
   70   continue
        if (tailp.lt.mincnt) then
          tailp=tailp+1
          it=it+1
        end if
        pval=dfloat(tailp)/dfloat(it)
      end if

      vchisq=vchisq/dfloat(max(1,it-1))
      bestz=0.0d0
      pos=0
      do 110 j=1, numal
        pos=pos+j
        if (vtrans(pos).gt.EPS) then
          x(j)=(dfloat(cntall(j,2))-mtrans(j))/sqrt(vtrans(pos))
        else
          x(j)=0.0d0
        end if
        if ((x(j)*x(j)).gt.abs(bestz)) bestz=x(j)*x(j)
  110 continue

      if (plevel.gt.0 .and. nca.eq.0) then
        write(*,'(/3a,3(/a,i6)))') 
     2 ' -------- Combined transmission test for "',locnam,'" --------',
     3    '                    marker(-) =',nuntyp,
     4    '       No. trait(+) marker(+) =',(nca+nco)/2,
     5    '          No. useful sibships =',nfam 
      else if (plevel.gt.0) then
        write(*,'(/3a/a/a)') 
     2 ' -------- Combined transmission test for "',locnam,'" --------',
     3 '   Allele   Affected   Unaffected   Total   E(Aff)    Z    P',
     5 ' -------------------------------------------------------------'
        casden=max(1.0,float(nca))
        conden=max(1.0,float(nco))
        do 30 j=1,numal
          write(*,'(i8,2(2x,i5,1x,a1,f3.2,a1),i7,2(1x,f6.1),1x,f6.4)')
     2     name(j),cntall(j,2),'(',float(cntall(j,2))/casden,')',
     3     cntall(j,1),'(',float(cntall(j,1))/conden,')',cntall(j,3),
     4     mtrans(j), x(j), chip(x(j)*x(j),1)
   30   continue
        write(*,'(a/a8,2(2x,i5,6x),i7)') 
     2 ' -------------------------------------------------------------',
     3      'Total',nca,nco,nca+nco
        write(*,'(3(/a,i6))') 
     2    '                    marker(-) =',nuntyp,
     3    '       No. trait(+) marker(+) =',(nca+nco)/2,
     4    '          No. useful sibships =',nfam 
        write(*,'(a,f6.1/a,i4)')
     2    ' Global association statistic =',ochisq,
     3    '           Degrees of freedom =',max(0,df) 
        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,')'
        if (plevel.gt.1) then
          write(*,'(/a/a)') 
     2 '  Allele     Tr   E(Tr)  Cov(Tr)',
     3 ' ------- ------ ------- --------------------------------------'
          pos=0
          do 150 j=1, numal
            write(*,'(i8,i7,10(1x,f7.2):)')
     2         name(j),cntall(j,2),mtrans(j),(vtrans(k),k=pos+1,pos+j)
            pos=pos+j
  150     continue
          write(*,'(/a/a,4(/a,3(2x,i7)))') 
     2 '  Parents genotyped   No. Fams  Useable  Aff Off',
     3 ' ------------------   --------  -------  -------',
     4 '  None               ',partyp(1,1),partyp(1,2),partyp(1,3),
     5 '  Father only        ',partyp(2,1),partyp(2,2),partyp(2,3),
     6 '  Mother only        ',partyp(3,1),partyp(3,2),partyp(3,3),
     7 '  Both parents       ',partyp(4,1),partyp(4,2),partyp(4,3) 
        end if
      else if (nca.gt.0 .and. numal.gt.1) then
        asyp=chip(bestz,1)
        asyp=min(1.0d0,(numal-1)*asyp)
        call phist(asyp,pval,histo)
        write(*,'(a10,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     2    locnam, nca/2, numal, bestz, asyp, asyp,
     3    it, 'RC-TDT   ', histo
        
      end if
      return
      end
C end-of-rctdt   
C
C Make list of possible parental genotypes for this sibship
C
      subroutine parimp(pg1,pg2,mg1,mg2,nsibs,set,parall)

      integer KNOWN, MAXSIZ, MISS
      parameter(KNOWN=0, MAXSIZ=1000, MISS=-9999)

      integer nsibs, mg1,mg2, pg1,pg2, parall, set(MAXSIZ,2)
      integer g(4,2), het, i, p11, p12, p21, p22, tmp
      logical d1,d2,d3,d4

C Both parents genotyped
      if (pg1.gt.KNOWN .and. mg1.gt.KNOWN) then
        parall=4
        return 
      end if
C
C initialize g() with a heterozygote genotype if possible
      het=1
      do 10 i=1, nsibs
      if (set(i,1).ne.set(i,2)) then
        het=i
        goto 11
      end if
   10 continue
   11 continue
      g(1,1)=set(het,1)
      g(1,2)=set(het,2)
C Categorise sibs genotype
C in terms of which allele is shared with starting genotype
      do 3 i=2, 4
        g(i,1)=MISS
        g(i,2)=MISS
    3 continue

      do 30 i=1, nsibs
        d1=(set(i,1).eq.g(1,1))
        d4=(set(i,2).eq.g(1,2))
        if (.not.(d1 .and. d4)) then
          d2=(set(i,1).eq.g(1,2))
          d3=(set(i,2).eq.g(1,1))
          if (d1) then
            g(2,1)=set(i,1)
            g(2,2)=set(i,2)
          else if (d3) then
            g(2,1)=set(i,2)
            g(2,2)=set(i,1)
          else if (d2) then
            g(3,1)=set(i,1)
            g(3,2)=set(i,2)
          else if (d4) then
            g(3,1)=set(i,2)
            g(3,2)=set(i,1)
          else 
            g(4,1)=set(i,1)
            g(4,2)=set(i,2)
          end if
        end if
   30 continue
  
C Fix order of 4th genotype so consistent with others
      if ((g(2,2).ne.MISS .and. g(4,2).ne.g(2,2)) .or.
     &    (g(3,1).ne.MISS .and. g(4,1).ne.g(3,1))) then
        tmp=g(4,2)
        g(4,2)=g(4,1)
        g(4,1)=tmp
      end if
C Produce parental phenosets and compare to any known genotypes
      p11=g(1,1)
      p21=g(1,2)
      p12=MISS
      p22=MISS
      if (g(2,2).ne.MISS) p22=g(2,2)
      if (g(4,2).ne.MISS) p22=g(4,2)
      if (g(3,2).ne.MISS) p12=g(3,2)
      if (g(4,1).ne.MISS) p12=g(4,1)
      call order(p11,p12)
      call order(p21,p22)
      if ((mg1.gt.KNOWN .and. ((mg1.eq.p11 .and. mg2.eq.p12)  .or.
     2    (p21.ne.MISS .and. (mg1.ne.p21 .or. mg2.ne.p22)) .or.
     3    (p21.eq.MISS .and. mg1.ne.p22 .and. mg2.ne.p22)))  .or.
     4    (pg1.gt.KNOWN .and. ((pg1.eq.p21 .and. pg2.eq.p22) .or.
     5    (p11.ne.MISS .and. (pg1.ne.p11 .or. pg2.ne.p12)) .or.
     6    (p11.eq.MISS .and. pg1.ne.p12 .and. pg2.ne.p12)))) then
        call swap(p11,p21)
        call swap(p12,p22)
      end if
C Return observed and imputed genotypes
      if (mg1.le.KNOWN) then
        if (p21.ne.MISS) mg1= -p21
        if (p22.ne.MISS) mg2= -p22
      end if
      if (pg1.le.KNOWN) then
        if (p11.ne.MISS) pg1= -p11
        if (p12.ne.MISS) pg2= -p12
      end if

      parall=0
      if (pg1.ne.MISS) parall=parall+1
      if (pg2.ne.MISS) parall=parall+1
      if (mg1.ne.MISS) parall=parall+1
      if (mg2.ne.MISS) parall=parall+1
      return
      end
C end-of-parimp
C
C Simulate the null distribution of sibship genotypes
C Parental alleles imputed via the children must be transmitted 
C at least once to that sibship
C Furthermore, if two imputed alleles are the same in the two parents,
C then these must be transmitted together to at least one child
C
      subroutine rctperm(pg1,pg2,mg1,mg2,nsibs,set)

      integer KNOWN, MAXSIZ, MISS
      parameter(KNOWN=0, MAXSIZ=1000, MISS=-9999)

      integer nsibs,mg1,mg2,pg1,pg2, set(MAXSIZ,2)
      integer all(2,2),gen(2,2),hom0,homimp,i,imp0,imputd, 
     &        p1(2),p2(2),swap,tmp,tr1,tr2
C functions
      integer irandom, ranall

C Allow restart since rejection sampling to meet conditions

      do 2 i=1, 2
      do 2 j=1, 2
        all(i,j)=0
        gen(i,j)=0
    2 continue
      if (pg1.lt.KNOWN .and. pg1.ne.MISS) all(1,1)=1
      if (pg2.lt.KNOWN .and. pg2.ne.MISS) all(1,2)=1
      if (mg1.lt.KNOWN .and. mg1.ne.MISS) all(2,1)=1
      if (mg2.lt.KNOWN .and. mg2.ne.MISS) all(2,2)=1
      imp0=all(1,1)+all(1,2)+all(2,1)+all(2,2)

      if ((all(1,1)+all(2,1)).eq.2 .and. pg1.eq.mg1) gen(1,1)=1
      if ((all(1,1)+all(2,2)).eq.2 .and. pg1.eq.mg2) gen(1,2)=1
      if ((all(1,2)+all(2,1)).eq.2 .and. pg2.eq.mg1) gen(2,1)=1
      if ((all(1,2)+all(2,2)).eq.2 .and. pg2.eq.mg2) gen(2,2)=1
      hom0=gen(1,1)+gen(1,2)+gen(2,1)+gen(2,2)

    1 continue

      homimp=hom0
      imputd=imp0
      p1(1)=pg1
      p1(2)=pg2
      p2(1)=mg1
      p2(2)=mg2
      all(1,1)=gen(1,1)
      all(1,2)=gen(1,2)
      all(2,1)=gen(2,1)
      all(2,2)=gen(2,2)
      do 10 i=1, nsibs
        tr1=ranall(p1)
        tr2=ranall(p2)
        if (all(tr1,tr2).eq.1) then
          homimp=homimp-1
          all(tr1,tr2)=0
        end if
        call conoff(tr1,p1,imputd,set(i,1))
        call conoff(tr2,p2,imputd,set(i,2))
   10 continue

      if (imputd.gt.0 .or. homimp.gt.0) goto 1
C
C If matching conditions, now permute genotypes within sibship
C
      do 20 i=1,nsibs
        swap=irandom(1,nsibs)
        tmp=set(swap,1)
        set(swap,1)=set(i,1)
        set(i,1)=tmp
        tmp=set(swap,2)
        set(swap,2)=set(i,2)
        set(i,2)=tmp
   20 continue
      do 30 i=1,nsibs
        call order(set(i,1), set(i,2))
   30 continue
      return
      end
C end-of-rctperm
C
C Randomly transmit nonmissing alleles
      integer function ranall(par)
      integer MISS
      parameter(MISS=-9999)
      integer par(2)
C functions
      integer irandom
      if (par(1).ne.MISS .and. par(2).ne.MISS) then
        ranall=irandom(1,2)
      else if (par(2).eq.MISS) then
        ranall=1
      else
        ranall=2
      end if
      return
      end
C end-of-ranall
C 
C Conditional parent-offspring transmission
C Flag whether an imputed parental allele is transmitted 
      subroutine conoff(tr,par,imputd,off)
      integer KNOWN
      parameter (KNOWN=0)
      integer imputd,off,par(2),tr
      
      if (par(tr).lt.KNOWN) then
        imputd=imputd-1
        par(tr)= -par(tr)
      end if
      off=par(tr)
      return
      end
C end-of-condoff
C
C One simulation of entire set of informative nuclear families 
C
      subroutine rctsim(wrk2,pg1,pg2,mg1,mg2,nsibs,aff,set,numal,trans)
      integer MAXALL, MAXSIZ
      parameter(MAXALL=60, MAXSIZ=1000)

      integer mg1,mg2,nsibs,numal,pg1,pg2,wrk2

      integer aff(MAXSIZ), set(MAXSIZ,2)  
      double precision trans(MAXALL)

      integer i,j

      do 5 j=1,numal  
        trans(j)=0.0d0
    5 continue
      rewind(wrk2)
   10 continue
        read(wrk2,end=50) pg1,pg2,mg1,mg2,nsibs,
     &                   (aff(i),set(i,1),set(i,2),i=1,nsibs)
        call rctperm(pg1,pg2,mg1,mg2,nsibs,set)
        do 20 i=1,nsibs
        if (aff(i).eq.2) then
          trans(set(i,1))=trans(set(i,1))+1.0d0
          trans(set(i,2))=trans(set(i,2))+1.0d0
        end if
   20   continue
      goto 10
   50 continue
      return
      end
C end-of-rctsim
C
C test if useful for RC-TDT/FBAT
C
      logical function rctuse(pg1,pg2,mg1,mg2,
     &                        ptyped,parall,contrib,naff)
      integer MISS
      parameter (MISS=-9999)
      integer mg1,mg2,pg1,pg2
      integer contrib,naff,parall,ptyped
      logical h1, h2

      h1=(pg1.ne.MISS .and.abs(pg1).ne.abs(pg2))
      h2=(mg1.ne.MISS .and.abs(mg1).ne.abs(mg2))

      rctuse=.true.
C Both parents homozygous or insufficient parental genotypes
      if (.not.(h1.or.h2) .or.  parall.le.2) then
        rctuse=.false.
        return
C Both parents typed
      else if (ptyped.eq.4) then
        return
C Affected and unaffected children and 3 or 4 identifiable parental alleles
      else if (parall.gt.2 .and. contrib.gt.naff) then
        return
C More than 2 affected children and...
      else if (contrib.gt.2) then
C 4 parental alleles
        if (parall.eq.4) then 
          return
C or 3 parental alleles 12 x 3- or 1- x 23
        else if (h1 .and. abs(pg1).ne.abs(mg2) .and.
     &           abs(pg2).ne.abs(mg2)) then
          return
        else if (h2 .and. abs(mg1).ne.abs(pg2) .and.
     &           abs(mg2).ne.abs(pg2)) then
          return
        end if
      end if
      rctuse=.false.
      return
      end
C end-of-rctuse
