C
C N-way cross-tabulation
C
      subroutine xtab(wrk,analys,nloc,loclist,loc,locpos,loctyp,
     2                pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3                numloc,val, values,idx,icount,plevel)
      integer KNOWN, MAXSIZ, MAXLOC, MISS, VSIZ
      parameter(KNOWN=0, MAXSIZ=1000, MAXLOC=120, 
     &          MISS=-9999, VSIZ=MAXSIZ*MAXLOC)
 
      integer analys,nloc, numloc,plevel,wrk
      integer loclist(nloc)
C current data vector
      real val(MAXSIZ)
C
C Locus structure:
C number of loci, locus name, locus type, and locus position in file
C
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)
C
C contingency table: idx points to data vector in values
      integer ncells
      integer idx(MAXSIZ), icount(MAXSIZ)
      integer topcat
      real values(VSIZ)
C  Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C
      integer i, iwt, j, lpos, margin, nmarg, nmiss, pos, tot, totdim
      integer ndim(MAXSIZ)
      logical last

      nmarg=0
      nmiss=0
      ncells=0
      topcat=0
      tot=0
      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

        do 7 i=1,num
          do 8 j=1, nloc
            lpos=locpos(loclist(j))
            val(j)=locus(i,lpos)
            if (val(j).eq.MISS .or. 
     &          (loctyp(loclist(j)).le.2 .and. val(j).le.KNOWN)) then
              nmiss=nmiss+1
              goto 7
            else if (loctyp(loclist(j)).le.2) then
              val(j)=1000.0*locus(i,lpos)+locus(i,lpos+1)
            end if
    8     continue
          tot=tot+1
          call qtabn(nloc,val,ncells,MAXSIZ,idx,icount,0,
     &               topcat,VSIZ,values,1)
    7   continue
      goto 5
   20 continue
C accumulate table margins
      if (nloc.gt.1) then
        margin=ncells
        do 50 i=1,ncells
          pos=idx(i)
          do 60 j=1, nloc
            val(1)=float(j)
            val(2)=values(pos)
            iwt=icount(i)
            call qtabn(2,val,nmarg,MAXSIZ,idx,icount,margin,
     &                 topcat,VSIZ,values,iwt)
            pos=pos+1
   60     continue
   50   continue
        call dimtab(nloc, ncells, nmarg, idx, values, ndim, totdim)
      end if
C write the table
      if (nloc.eq.1) then
        if (plevel.gt.0) then
          write(*,'(/a/3a/a)')
     2    '------------------------------------',
     3    'Tabulation of "',loc(loclist(1)),'"',
     5    '------------------------------------'
        end if
      else 
        write(*,'(/a/5a/a)')
     2    '------------------------------------------------',
     3    'Cross-tabulation of "',loc(loclist(1)),
     4    '" ... "',loc(loclist(nloc)),'"',
     5    '------------------------------------------------'
      end if
C print rectangular or listwise table
      if (nloc.eq.1 .and. plevel.lt.1) then
        call onetab(nloc, loclist, loc, loctyp, ncells, idx, 
     &              icount, values, nmiss, tot)
      else if (nloc.eq.2) then
        call wrtab(analys, nloc, loclist, ndim, loc, loctyp, ncells,
     &              nmarg, idx, icount, values, tot, totdim)
      else
        call listab(nloc, loclist, loc, loctyp, ncells, idx, 
     &              icount, values, tot)
      end if
      return
      end
C end-of-xtab  
C
C Get extent of contingency table
C
      subroutine dimtab(nloc, ncells, nmarg, idx, values, ndim, totdim)
      integer nloc, nmarg, ncells, totdim
      integer ndim(nloc)
C contingency table
      integer idx(*)
      real values(*)
C local variables 
      integer curr, n, i
      n=0
      curr=1
      do 70 i=ncells+1, ncells+nmarg
        if (int(values(idx(i))).eq.curr) then
          n=n+1
        else
          ndim(curr)=n
          curr=curr+1
          n=1
        end if
   70 continue
      ndim(curr)=n
      totdim=ndim(1)
      do 100 i=2, nloc
        totdim=totdim*ndim(i)
  100 continue
      return
      end
C end-of-dimtab
C
C print summary of one-way table
      subroutine onetab(nloc, loclist, loc, loctyp, ncells, idx, 
     &                  icount, values, nmiss, tot)
      integer KNOWN, MAXSIZ, MAXLOC, MISS, VSIZ
      parameter(KNOWN=0, MAXSIZ=1000, MAXLOC=120, 
     &          MISS=-9999, VSIZ=MAXSIZ*MAXLOC)
      integer nloc, nmiss, tot
      integer loclist(nloc)
C number of loci, locus name, locus type, and locus position in file
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC)
C contingency table
      integer idx(MAXSIZ), icount(MAXSIZ)
      real values(VSIZ)
C local variables 
      integer i, j, n1, n2
      character*7 gtp
      i=loclist(1)
      if (loctyp(i).eq.4) then
        n1=0
        n2=0
        do 95 j=1, ncells
          if (values(idx(j)).eq.1.0d0) n1=icount(j)
          if (values(idx(j)).eq.2.0d0) n2=icount(j)
   95   continue
        write(*,'(a,1x,a,i4,2(a8,i4))') 
     &    loc(i),'x:',nmiss,'y:',n2,'n:',n1
      elseif (ncells.gt.6) then
        write(*,'(a,1x,a,i4,a8,i4,a,i4,a)') 
     &    loc(i),'x:',nmiss,'y:',tot,' (',ncells,' unique values)'
      else
        write(*,'(a,1x,a,i4,$)') loc(i),'x:',nmiss
        if (loctyp(i).eq.3) then
          do 100 j=1,ncells
            write(*,'(1x,f7.1,a,i4,$)') values(idx(j)),':',icount(j)
  100     continue
        else
          do 110 j=1,ncells
            call wrgtp(int(values(idx(j)))/1000,
     &                 mod(int(values(idx(j))),1000),gtp,1)
            call juststr('r',gtp,7)
            write(*,'(1x,2a,i4,$)') gtp,':',icount(j)
  110     continue
        end if
        write(*,*)
      end if
      return
      end
C end-of-onetab  
C
C print listwise contingency table
      subroutine listab(nloc, loclist, loc, loctyp, ncells, idx, 
     &                  icount, values, tot)
      integer KNOWN, MAXSIZ, MAXLOC, MISS, VSIZ
      parameter(KNOWN=0, MAXSIZ=1000, MAXLOC=120, 
     &          MISS=-9999, VSIZ=MAXSIZ*MAXLOC)
 
      integer nloc, tot
      integer loclist(nloc)
C number of loci, locus name, locus type, and locus position in file
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC)
C contingency table
      integer idx(MAXSIZ), icount(MAXSIZ)
      real values(VSIZ)
C local variables 
      integer i, j
      character*10 cval
      double precision wt

      do 100 j=1, nloc
        cval=loc(loclist(j))
        call juststr('c',cval,10)
        write(*,'(a10,1x,$)') cval
  100 continue
      write(*,'(a/a,$)') '   Count  Percent',
     &  '------------------'
      do 110 j=1, nloc
        write(*,'(a10,$)') '----------'
  110 continue
      write(*,*)
      wt=100.0d0/dfloat(tot)
      do 150 i=1,ncells
        pos=idx(i)
        do 160 j=1, nloc
          call wrtrait(values(pos),cval,loctyp(loclist(j)))
          write(*,'(a10,1x,$)') cval
          pos=pos+1
  160   continue
        write(*,'(1x,i6,4x,f5.1)') icount(i), wt*dfloat(icount(i))
  150 continue
      return
      end
C end-of-listab
C
C print RxC contingency table 
      subroutine wrtab(analys, nloc, loclist, ndim, loc, loctyp, 
     &                 ncells, nmarg, idx, icount, values, tot, totdim)
      integer KNOWN, MAXSIZ, MAXLOC, MISS, VSIZ
      double precision TOL
      parameter(KNOWN=0, MAXSIZ=1000, MAXLOC=120, 
     &          MISS=-9999, TOL=1.0d-6, VSIZ=MAXSIZ*MAXLOC)
 
      integer analys, nloc, tot, totdim
      integer loclist(nloc), ndim(nloc)
C number of loci, locus name, locus type, and locus position in file
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC)
C contingency table
      integer ncells, nmarg
      integer idx(MAXSIZ), icount(MAXSIZ)
      real values(VSIZ)
C local variables 
      integer address, cnt, df, i,  icell, n(4), 
     &        nxtcell, offset, pos, t1, t2
      character*10 cval1, cval2
      real curr
      double precision er, e, kwstat, nr, lrts, rank, rankg, ss, ties
C functions
      double precision chip

      t1=loclist(1)
      t2=loclist(2)
      cval1=loc(t1)
      cval2=loc(t2)
      n(1)=0
      n(2)=0
      n(3)=0
      n(4)=0
      lrts=0.0d0
C print as 2x2 table
      if (loctyp(t1).eq.4 .and. loctyp(t2).eq.4) then
        do 10 i=1,ncells
          n(7-2*int(values(idx(i)))-int(values(idx(i)+1)))=icount(i)
   10   continue
        call juststr('c',cval2,10)
        write(*,'(/19x,a10/a10,8x,a3,5x,a/a)') cval2,cval1,
     &    'Yes',' No  Percent','--------------------------------------'
        write(*,'(7x,a3,5x,i6,2x,i6,4x,f5.1)') 
     &    'Yes',n(1),n(2),1.0d2*dfloat(n(1))/dfloat(max(1,n(1)+n(2))) 
        write(*,'(7x,a3,5x,i6,2x,i6,4x,f5.1)') 
     &    ' No',n(3),n(4),1.0d2*dfloat(n(3))/dfloat(max(1,n(3)+n(4))) 
          write(*,'(/a,f6.1)') 'Odds Ratio              = ',
     2      (0.5d0+dfloat(n(1)))*(0.5d0+dfloat(n(4)))/
     3      (0.5d0+dfloat(n(2)))/(0.5d0+dfloat(n(3))) 
C print as RxC table
      else if ((ndim(1).lt.20.or.loctyp(t1).ne.3) .and. 
     &         ndim(2).lt.8 .and. analys.eq.1) then
        write(*,'(/22x,a10/2a,$)') cval2,cval1,' '
        offset=ncells+ndim(1)
        do 20 i=1, ndim(2)
          pos=idx(offset+i)+1
          call wrtrait(values(pos),cval2,loctyp(t2))
          write(*,'(3x,a10,$)') cval2
   20   continue
        write(*,'(/11x,8(a13):)') ('--------------', i=1, ndim(2))
          
        offset=ncells
        icell=0
        nxtcell=1
        call fullidx(nxtcell, nloc, ndim, ncells, idx,
     &               values,totdim,address)
        do 50 i=1, ndim(1)
          call wrtrait(values(idx(offset+i)+1),cval1,loctyp(t1))
          write(*,'(a10,1x,$)') cval1
          nr=dfloat(icount(offset+i))
          er=nr/dfloat(max(1,tot))
          do 25 j=1, ndim(2)
            icell=icell+1
            if (icell.eq.address) then
              cnt=icount(nxtcell)
              nxtcell=nxtcell+1
              call fullidx(nxtcell, nloc, ndim, ncells, idx,
     &                     values, totdim, address)
            else
              cnt=0
            end if
            e=dfloat(cnt)/nr
            if (e.eq.1.0d0) then
              write(*,'(1x,i5,1x,a,$)') cnt,'(1.00)'
            else
              write(*,'(1x,i5,1x,a,f4.3,a,$)') cnt,'(',e,')'
            end if
            e=er*dfloat(icount(offset+ndim(1)+j))
            if (e.gt.TOL .and. cnt.gt.0) then
              lrts=lrts+dfloat(cnt)*log(dfloat(cnt)/e)
            end if
   25     continue
          write(*,*)
   50   continue
        lrts=lrts+lrts
        df=(ndim(1)-1)*(ndim(2)-1)
        write(*,'(/a,i6/a,f6.1/a,i4/a,f6.4)')
     2    '    No. complete observations =',tot,
     3    '    LR contingency chi-square =',lrts,  
     4    '           Degrees of freedom =',df,
     5    '                      P-value =', chip(lrts,df)
C one-way table of means
      else if (analys.eq.2 .or.(ndim(1).lt.8.and.loctyp(t2).eq.3)) then
        write(*,'(/22x,a10/a,6x,a,14x,a,7x,a/11x,a)') 
     2    cval2,cval1,'Mean','SD','Count',
     3       '---------------------------------------'
        e=0.0d0
        kwstat=0.0d0
        rankg=0.0d0
        ss=0.0d0
        icell=0
        offset=ncells+ndim(1)
        curr=values(idx(1))
        do 80 i=1, ncells
          if (values(idx(i)).ne.curr) then
            kwstat=kwstat+rankg*rankg/dfloat(icell)
            call wrtrait(curr,cval1,loctyp(t1))
            write(*,'(a10,3x,f12.4,3x,f12.4,1x,i7)') 
     &        cval1, e, sqrt(ss/dfloat(max(icell-1,1))), icell
            curr=values(idx(i))
            icell=0
            e=0.0d0
            rankg=0.0d0
            ss=0.0d0
          end if
          icell=icell+icount(i)
          call moment(icell,dble(values(idx(i)+1)),e,ss)
          rank=0.0d0
          do 90 j=1, ndim(2)
            rank=rank+dfloat(icount(offset+j))
            if (values(idx(i)+1).eq.values(idx(offset+j)+1)) then
               rank=rank-0.5d0*float(icount(offset+j)-1)
               goto 91
            end if
   90     continue
   91     continue
          rankg=rankg+dfloat(icount(i))*rank
   80   continue
        kwstat=kwstat+rankg*rankg/dfloat(icell)
        call wrtrait(curr,cval1,loctyp(t1))
        write(*,'(a10,3x,f12.4,3x,f12.4,1x,i7)') 
     &    cval1, e, sqrt(ss/dfloat(max(icell-1,1))), icell
C Kruskal-Wallis test statistic, then correction for ties
        kwstat=12.0d0*kwstat/dfloat(tot*(tot+1)) - dfloat(3*(tot+1))
        ties=0.0d0
        do 100 j=1, ndim(2)
          ties=ties+dble(icount(offset+j)**3-icount(offset+j))
  100   continue
        kwstat=kwstat/(1.0d0 - ties/dfloat(tot**3-tot))
        df=(ndim(1)-1)
        write(*,'(/a,f7.2,a,i3,a,f6.4,a)') 
     2     'Kruskal-Wallis H=', kwstat, 
     3     ' df=',df,' (P=', chip(kwstat,df),')'
      else
        call listab(nloc, loclist, loc, loctyp, ncells, idx, 
     &              icount, values, tot)
      end if
      return
      end
C end-of-wrtab 
C
C Location of given cell in complete table
C
      subroutine fullidx(icell, nloc, ndim, ncells, 
     &                   idx, values, totdim, address)
      integer MAXSIZ, MAXLOC, VSIZ
      parameter(MAXSIZ=1000, MAXLOC=120, VSIZ=MAXSIZ*MAXLOC)
      integer address, icell, nloc, offset, totdim 
      integer ndim(nloc)
C contingency table
      integer ncells
      integer idx(MAXSIZ)
      real values(VSIZ)

      integer i, j, mult, pos

      address=1
      mult=totdim
      offset=ncells
      do 10 i=1, nloc
        mult=mult/ndim(i)
        do 20 j=1, ndim(i)
          pos=idx(offset+j)+1
          if (values(pos).eq.values(idx(icell)+i-1)) then
            address=address+mult*(j-1)
          end if
   20   continue
        offset=offset+ndim(i)
   10 continue
      return
      end
C end-of-fullidx
C
C
C Binary trait prevalences and recurrence risks.
C
      subroutine segrat(wrk,locnam,trait,pedigree,actset,num,nfound,
     &                 id,fa,mo,sex, locus, numloc)
C
      integer numloc,trait,wrk
      character*10 locnam
C  Pedigree structure
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C
      integer i, pos, sta, currf,currm
      integer aff(6),den(6),mat(3),matyp,naff,nmiss,nmissf,nsib
      integer sscon, ssdis, hscon, hsdis, gpcon, gpdis, pocon, podis
      real segr(6), ssrec,hsrec,porec, gprec, marrec
      logical last, sibshp
      gpcon=0
      gpdis=0
      gprec=0.0
      hscon=0
      hsdis=0
      hsrec=0.0
      marrec=0.0
      naff=0
      nmiss=0
      nmissf=0
      nsib=0
      pocon=0
      podis=0
      porec=0.0
      sscon=0
      ssdis=0
      ssrec=0.0
      mat(1)=0
      mat(2)=0
      mat(3)=0
      do 1 i=1,6
        aff(i)=0
        den(i)=0
        segr(i)=0.0
    1 continue
      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

        do 7 i=1,num
        if (locus(i,trait).ne.1 .and. locus(i,trait).ne.2) then
          nmiss=nmiss+1
          if (i.le.nfound) nmissf=nmissf+1
        else
          den(4)=den(4)+1
          if (locus(i,trait).eq.2) aff(4)=aff(4)+1
          if (i.le.nfound) then
             den(5)=den(5)+1
             if (locus(i,trait).eq.2) aff(5)=aff(5)+1
          else
             den(6)=den(6)+1
             if (locus(i,trait).eq.2) aff(6)=aff(6)+1
          end if
          do 8 j=max(nfound+1,i+1),num
          if (locus(j,trait).eq.1 .or. locus(j,trait).eq.2) then
            if ((fa(j).eq.i.or.mo(j).eq.i) .or.
     &          (i.gt.nfound .and. (fa(i).eq.j.or.mo(i).eq.j))) then
              if (locus(i,trait).eq.2.and.locus(j,trait).eq.2) then
                pocon=pocon+1
              elseif (locus(i,trait).ne.locus(j,trait)) then
                podis=podis+1
              end if
            elseif ((fa(j).gt.nfound .and. 
     2	             (fa(fa(j)).eq.i .or. mo(fa(j)).eq.i)) .or.
     3              (mo(j).gt.nfound .and. 
     4	             (fa(mo(j)).eq.i .or. mo(mo(j)).eq.i)))
     5      then
              if (locus(i,trait).eq.2.and.locus(j,trait).eq.2) then
                gpcon=gpcon+1
              elseif (locus(i,trait).ne.locus(j,trait)) then
                gpdis=gpdis+1
              end if
            elseif (i.gt.nfound) then
              if (fa(i).eq.fa(j).and.mo(i).eq.mo(j)) then
                if (locus(i,trait).eq.2.and.locus(j,trait).eq.2) then
                  sscon=sscon+1
                elseif (locus(i,trait).ne.locus(j,trait)) then
                  ssdis=ssdis+1
                end if
              elseif (fa(i).eq.fa(j).or.mo(i).eq.mo(j)) then
                if (locus(i,trait).eq.2.and.locus(j,trait).eq.2) then
                  hscon=hscon+1
                elseif (locus(i,trait).ne.locus(j,trait)) then
                  hsdis=hsdis+1
                end if
              elseif ((fa(i).gt.nfound .and. 
     2	               (fa(fa(i)).eq.j .or. mo(fa(i)).eq.j)) .or.
     3                (mo(i).gt.nfound .and. 
     4	               (fa(mo(i)).eq.j .or. mo(mo(i)).eq.j))) 
     5        then
                if (locus(i,trait).eq.2.and.locus(j,trait).eq.2) then
                  gpcon=gpcon+1
                elseif (locus(i,trait).ne.locus(j,trait)) then
                  gpdis=gpdis+1
                end if
              end if
            end if
          end if
    8     continue
        end if
    7   continue
C
C If any nonfounders, do segregation ratios

        if (nfound.eq.num) goto 5

        pos=nfound+1
        sta=pos
        currf=fa(sta)
        currm=mo(sta)
        last=.false.
        sibshp=.false.        
C through sibship by sibship
   10   continue
          if (pos.gt.num) then
            last=.true.
            sibshp=.true.
          elseif (currf.ne.fa(pos) .or. currm.ne.mo(pos)) then
            sibshp=.true.
          end if
          if (sibshp .and. locus(currf,trait).ne.MISS .and.
     2        locus(currm,trait).ne.MISS) 
     3    then
            matyp=1
            if (locus(currf,trait).eq.2) matyp=matyp+1
            if (locus(currm,trait).eq.2) matyp=matyp+1
            mat(matyp)=mat(matyp)+1
            do 12 i=sta,pos-1
              if (locus(i,trait).ne.MISS) then
                nsib=nsib+1
                den(matyp)=den(matyp)+1
              end if
              if (locus(i,trait).eq.2) then
                aff(matyp)=aff(matyp)+1
                naff=naff+1
              end if
   12       continue
          end if
C exit if last sibship
        if (last) goto 5
C else move to next sibship if appropriate and iter
          if (sibshp) then
            sibshp=.false.
            sta=pos
            currf=fa(sta)
            currm=mo(sta)
          end if
          pos=pos+1
        goto 10

C end of segregation ratio loop

   20 continue
C
C last pedigree -- write output
C
      write(*,'(/a/a,a10,a/a/)')
     2  '------------------------------------------------',
     3  'Segregation ratios for trait "',locnam,'"',
     4  '------------------------------------------------'
      do 22 i=1,6
   22   if (den(i).gt.0) segr(i)=float(aff(i))/float(den(i))
      write(*,'(a/a)') 'Total sample   All       Fndrs     Nonfndrs',
     &                 '-------------------------------------------'
      write(*,'(3x,a8,3(1x,i4,a1,i4)/3x,a8,3(5x,f5.3)/3x,a8,3(5x,i5))') 
     2      'Aff/Tot ', aff(4),'/',den(4), aff(5),'/',den(5),
     3      aff(6),'/',den(6), 'Prop Aff',segr(4), segr(5), segr(6),
     4      'Missing ',nmiss,nmissf,nmiss-nmissf
      write(*,'(/a/a)') 'Mating Type     UxU       UxA       AxA',
     &                  '-------------------------------------------'
      write(*,'(3x,a8,3i10/3x,a8,3(1x,i4,a1,i4)/3x,a8,3(5x,f5.3))') 
     2      'Matings ', mat(1),mat(2),mat(3),
     3      'Aff/Tot ', aff(1),'/',den(1), aff(2),'/',den(2),
     4      aff(3),'/',den(3), 'Prop Aff',segr(1), segr(2), segr(3)
      write(*,'(/a/a)') 'Relative pair  RecRisk   Aff-Aff   Aff-UnA',
     &                  '-------------------------------------------'
      if ((pocon+podis).gt.0) 
     &  porec=float(2*pocon)/float(2*pocon+podis)
      if ((sscon+ssdis).gt.0) 
     &  ssrec=float(2*sscon)/float(2*sscon+ssdis)
      if ((hscon+hsdis).gt.0) 
     &  hsrec=float(2*hscon)/float(2*hscon+hsdis)
      if ((gpcon+gpdis).gt.0) 
     &  gprec=float(2*gpcon)/float(2*gpcon+gpdis)
      if ((mat(2)+mat(3)).gt.0) 
     &  marrec=float(2*mat(3))/float(2*mat(3)+mat(2))
      write(*,'(3x,a,5x,f5.3,2(5x,i5),4(/3x,a,5x,f5.3,2(5x,i5)))')  
     2      'Marital ',marrec, mat(3), mat(2),
     3      'Gparent ', gprec, gpcon, gpdis,
     4      'Halfsib ', hsrec, hscon, hsdis,
     5      'Par-Off ', porec, pocon, podis,
     6      'Fullsib ', ssrec, sscon, ssdis
      return
      end
C end-of-segrat
C                                                                           
C  Segregation ratios using Davie 1976
C
      subroutine davie(wrk,loc1,trait,loc2,proband,pedigree,actset,num,
     &                 nfound, id,fa,mo,sex, locus, numloc, plevel)
C
      integer numloc,plevel,proband,trait,wrk
      character*10 loc1, loc2
C  Pedigree structure
      integer MAXSIZ, MAXLOC, MISS, NCLASS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999, NCLASS=4)
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C
      integer currf, currm, i, matyp, npro, pos, sta
      integer j(NCLASS), mat(NCLASS), q(NCLASS), r(NCLASS), t(NCLASS)
      double precision den, phat(NCLASS), se(NCLASS)
      logical last, sibshp
C functions
      integer eow

      write(*,'(/a/3a/a)')
     2  '---------------------------------------------------',
     3  'Corrected segregation ratios for trait "',loc1,'"',
     4  '---------------------------------------------------'
      if (trait.eq.proband) then
        write(*,'(a)') 
     &    'NOTE:  Assuming complete ascertainment.'
      else
        write(*,'(3a)') 'NOTE:  Proband defined by "',
     &     loc2(1:eow(loc2)),'".'
      end if

      if (plevel.gt.1) then
        write(*,'(/a,11x,a)') 'Pedigree   Parents',
     &                  'Faff Maff  Npro Naff  Tot'
      end if
      
      do 1 i=1,NCLASS
        j(i)=0
        mat(i)=0
        phat(i)=0.0d0
        r(i)=0
        q(i)=0
        t(i)=0
    1 continue
      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

        pos=nfound+1
        sta=pos
        currf=fa(sta)
        currm=mo(sta)
        last=.false.
        sibshp=.false.        
C through sibship by sibship
   10   continue
          if (pos.gt.num) then
            last=.true.
            sibshp=.true.
          elseif (currf.ne.fa(pos) .or. currm.ne.mo(pos)) then
            sibshp=.true.
          end if
          if (sibshp) then
            npro=0
            do 13 i=sta,pos-1
            if (locus(i,proband).eq.2 .and. locus(i,trait).eq.2) then
              npro=npro+1
            end if
   13       continue
            call davstat(4,pos,sta,npro,trait,locus,mat,j,q,t,r)
            if (locus(currf,trait).ne.MISS .and.  
     &          locus(currm,trait).ne.MISS) then
              matyp=1
              if (locus(currf,trait).eq.2.0) matyp=matyp+1
              if (locus(currm,trait).eq.2.0) matyp=matyp+1
              call davstat(matyp,pos,sta,npro,trait,locus,mat,j,q,t,r)
            end if

            if (plevel.gt.1) then
              call  davwri(pedigree, currf, currm, pos, sta,
     &                     npro, trait, id, locus)
            end if
          end if
C exit if last sibship
        if (last) goto 15
C else move to next sibship if appropriate and iter
          if (sibshp) then
            sibshp=.false.
            sta=pos
            currf=fa(sta)
            currm=mo(sta)
          end if
          pos=pos+1
        goto 10
   15   continue
C
      goto 5
   20 continue
C
C last pedigree -- write output
C
      do 100 i=1,NCLASS
        den=dfloat(t(i)-j(i))
        if (den.gt.0.0d0) then
          phat(i)=dfloat(r(i)-j(i))/den
          se(i)=dfloat((r(i)-j(i))*(t(i)-r(i)))/den**3.0d0 + 
     &          dfloat(2*q(i)*(t(i)-r(i))**2)/den**4.0d0 
          se(i)=sqrt(se(i)) 
        else
          phat(i)=0.0d0
          se(i)=0.0d0
        end if
  100 continue
      write(*,'(/a/a)') 'Mating Type   UxU      UxA      AxA     All',
     &  '-----------------------------------------------'
      write(*,'(3x,a8,4i9/3x,a8,4(1x,i3,a1,i4),2(/3x,a8,4(4x,f5.3)))') 
     2  'Matings ', mat(1),mat(2),mat(3),mat(4), 'Aff/Tot ',
     3   r(1),'/',t(1), r(2),'/',t(2), r(3),'/',t(3), r(4),'/',t(4),
     5  'Risk    ',phat(1), phat(2), phat(3), phat(4),
     6  'Std Err ',se(1),se(2),se(3), se(4)
      return
      end
C end-of-davie
C
C Accumulate counts needed for Davie formula in current family
C
      subroutine davstat(typ,pos,sta,npro,trait,locus,class,j,q,t,r)

      integer MAXSIZ, MAXLOC, MISS, NCLASS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999, NCLASS=4)
      integer npro, pos, sta, trait, typ
      integer class(NCLASS), j(NCLASS), q(NCLASS), r(NCLASS), t(NCLASS)
      real locus(MAXSIZ,MAXLOC)
C
      integer i

      class(typ)=class(typ)+1
      if (npro.eq.1) then
        j(typ)=j(typ)+1
      end if
      if (npro.eq.2) then
        q(typ)=q(typ)+1
      end if
      do 10 i=sta,pos-1
        if (locus(i,trait).ne.MISS) then
          t(typ)=t(typ)+1
        end if
        if (locus(i,trait).eq.2) then
          r(typ)=r(typ)+1
        end if
   10 continue
      return
      end
C end-of-davstat
C
C print prop affected per sibship
C
      subroutine davwri(pedigree, currf, currm, pos, sta, 
     &                  npro,trait,id,locus)

      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer currf, currm, npro, pos, sta, trait
      character*10 pedigree
      character*8 id(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer i, na, nt
      character*1 af, am
C
      na=0
      nt=0
      call wraff(locus(currf,trait),af)
      call wraff(locus(currm,trait),am)
      do 50 i=sta,pos-1
      if (locus(i,trait).ne.MISS) then
        nt=nt+1   
        if (locus(i,trait).eq.2.0) na=na+1   
      end if
   50 continue
      write(*,'(3(a,1x),2(3x,a1,1x),3i5)') 
     &  pedigree, id(currf), id(currm), af, am, npro, na, nt
      return
      end
C end-of-davwri
C
C Quantitative trait relatives means and covariances
C
      subroutine famcor(wrk,locnam,trait,pedigree,actset,num,nfound,
     &                 id,fa,mo,sex, locus, numloc,plevel)
 
      integer numloc,plevel,trait,wrk
      character*10 locnam
C  Pedigree structure
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C
      integer i, pos, sta, currf,currm, nships, nsibs
      integer nmiss,nmissf,npairs(5), tnum(3)
      double precision  mean(3), tvar(3), maxv(3), minv(3)
      double precision cov(5), mu(5,2), cvar(5,2), x1, x2
C Sibship variance test regression results
      double precision x(3),r(6),b(2)
      double precision alpha,beta,sea,seb,ssm,ssw,tvalb
      logical last, sibshp
      character*12 midpar
C functions
      double precision probst
      nmiss=0
      nmissf=0
      nships=0
      do 1 i=1,3
        maxv(i)=-1.0d20
        minv(i)=+1.0d20
        mean(i)=0.0d0
        tvar(i)=0.0d0
        tnum(i)=0 
    1 continue
      do 2 i=1,5
        mu(i,1)=0.0d0
        mu(i,2)=0.0d0
        npairs(i)=0
        cvar(i,1)=0.0d0
        cvar(i,2)=0.0d0
        cov(i)=0.0d0
    2 continue
      do 3 i=1,6
        r(i)=0.0d0
    3 continue
      j=0
      do 4 i=1,3
        j=j+i
        r(j)=-1.0d0
    4 continue
      write(*,'(/a/a,a10,a/a/)')
     2  '------------------------------------------------',
     3  'Summary statistics for trait "',locnam,'"',
     4  '------------------------------------------------'
      if (plevel.gt.1) then
        write(*,'(2a/2a)') 
     2  'Pedigree   Father   Mother   Midparent    Sibship Mean',
     3  ' log(Sibs Var)',
     4  '---------- -------- -------- ------------ ------------',
     5  ' ------------'
      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

        do 7 i=1,num
        if (locus(i,trait).eq.MISS) then
          nmiss=nmiss+1
          if (i.le.nfound) nmissf=nmissf+1
        else
          x1=dble(locus(i,trait))
          if (x1.gt.maxv(1)) then
            maxv(1)=x1
          end if
          if (x1.lt.minv(1)) then
            minv(1)=x1
          end if
	  tnum(1)=tnum(1)+1
          call moment(tnum(1),x1,mean(1),tvar(1))
          if (i.le.nfound) then
            if (x1.gt.maxv(2)) then
              maxv(2)=x1
            end if
            if (x1.lt.minv(2)) then
              minv(2)=x1
            end if
	    tnum(2)=tnum(2)+1
            call moment(tnum(2),x1,mean(2),tvar(2))
          else
            if (x1.gt.maxv(3)) then
              maxv(3)=x1
            end if
            if (x1.lt.minv(3)) then
              minv(3)=x1
            end if
	    tnum(3)=tnum(3)+1
            call moment(tnum(3),x1,mean(3),tvar(3))
          end if
          do 8 j=max(nfound+1,i+1),num
          if (locus(j,trait).ne.MISS) then
            x2=dble(locus(j,trait))
            if (fa(j).eq.i.or.mo(j).eq.i) then
              call corr(4,x1,x2,npairs,mu,cvar,cov)    
            elseif ((fa(j).gt.nfound .and. 
     2	            (fa(fa(j)).eq.i .or. mo(fa(j)).eq.i)) .or.
     3             (mo(j).gt.nfound .and. 
     4	            (fa(mo(j)).eq.i .or. mo(mo(j)).eq.i))) 
     5      then
              call corr(2,x1,x2,npairs,mu,cvar,cov)    
            elseif (i.gt.nfound) then
              if (fa(i).eq.j.or.mo(i).eq.j) then
                call corr(4,x2,x1,npairs,mu,cvar,cov)    
              elseif (fa(i).eq.fa(j).and.mo(i).eq.mo(j)) then
                call corr(5,x1,x2,npairs,mu,cvar,cov)    
                call corr(5,x2,x1,npairs,mu,cvar,cov)    
              elseif (fa(i).eq.fa(j).or.mo(i).eq.mo(j)) then
                call corr(3,x1,x2,npairs,mu,cvar,cov)    
                call corr(3,x2,x1,npairs,mu,cvar,cov)    
              elseif ((fa(i).gt.nfound .and. 
     2	            (fa(fa(i)).eq.j .or. mo(fa(i)).eq.j)) .or.
     3             (mo(i).gt.nfound .and. 
     4	            (fa(mo(i)).eq.j .or. mo(mo(i)).eq.j))) 
     5        then
                call corr(2,x2,x1,npairs,mu,cvar,cov)    
              end if
            end if
          end if
    8     continue
        end if
    7   continue

        pos=nfound+1
        sta=pos
        currf=fa(sta)
        currm=mo(sta)
        last=.false.
        sibshp=.false.        
C through sibship by sibship
   10   continue
          if (pos.gt.num) then
            last=.true.
            if (num.gt.nfound) sibshp=.true.
          elseif (currf.ne.fa(pos) .or. currm.ne.mo(pos)) then
            sibshp=.true.
          end if
          if (sibshp) then
            if (locus(currf,trait).ne.MISS .and. 
     2          locus(currm,trait).ne.MISS) 
     3      then
C marital correlation
              x1=dble(locus(currf,trait))
              x2=dble(locus(currm,trait))
              call corr(1,x1,x2,npairs,mu,cvar,cov)
              write(midpar,'(f12.4)') 0.5d0*(x1+x2)
            else
              midpar='       x    '
            end if
C within-sibship means and variances
            nsibs=0
            ssm=0.0d0
            ssw=0.0d0
            do 12 i=sta,pos-1
            if (locus(i,trait).ne.MISS) then
              x1=dble(locus(i,trait))
	      nsibs=nsibs+1
              call moment(nsibs,x1,ssm,ssw)
            end if
   12       continue
            if (nsibs.gt.1 .and. ssw.gt.0.0d0) then
              nships=nships+1
              x(1)=1.0d0
              x(2)=ssm
              x(3)=log(ssw/dfloat(max(1,nsibs-1)))
              if (plevel.gt.1) then
                write(*,'(a10,1x,a8,1x,a8,1x,a12,2(1x,f12.4))') 
     &            pedigree,id(currf),id(currm),midpar,x(2),x(3)
              end if
              call givenc(r, 6, 3, x, 1.0d0, ifail)
            end if
          end if
C exit if last sibship
        if (last) goto 15
C else move to next sibship if appropriate and iter
          if (sibshp) then
            sibshp=.false.
            sta=pos
            currf=fa(sta)
            currm=mo(sta)
          end if
          pos=pos+1
        goto 10
   15   continue
C
      goto 5
   20 continue
C
C last pedigree -- write output
C
      if (tnum(1).gt.0) then
        tvar(1)=tvar(1)/dfloat(max(1,tnum(1)-1))
        tvar(2)=tvar(2)/dfloat(max(1,tnum(2)-1))
        tvar(3)=tvar(3)/dfloat(max(1,tnum(3)-1))
	if (tnum(2).eq.0) then
	  maxv(2)=0.0d0
	  minv(2)=0.0d0
	elseif (tnum(3).eq.0) then
	  maxv(3)=0.0d0
	  minv(3)=0.0d0
	end if
        if (plevel.gt.1 .and. nships.gt.0) then
          write(*,*)
        end if
        write(*,'(a/a)')
     2   'Descriptive Stats       All     Founders  Nonfounders',
     3   '-----------------------------------------------------'
        write(*,'(5(a,3x,3(1x,f12.4)/),2(a,2x,3(4x,i5,4x)/))')
     2   'Means      ',mean(1),mean(2),mean(3),
     3   'Variances  ',tvar(1),tvar(2),tvar(3),
     3   'Stand Devs ',sqrt(tvar(1)),sqrt(tvar(2)),sqrt(tvar(3)),
     4   'Maxima     ',maxv(1),maxv(2),maxv(3),
     5   'Minima     ',minv(1),minv(2),minv(3),
     6   'No. obs    ',tnum(1),tnum(2),tnum(3),
     7   'No. missing',nmiss,nmissf,nmiss-nmissf
      else
        write(*,'(a/)') 'NOTE:  No nonmissing observations'
      end if
      do 30 i=1,5
        cvar(i,1)=sqrt(cvar(i,1)/dfloat(max(1,npairs(i)-1)))
        cvar(i,2)=sqrt(cvar(i,2)/dfloat(max(1,npairs(i)-1)))
        if (cvar(i,1).gt.0.0d0 .and. cvar(i,2).gt.0.0d0) then
          cov(i)=cov(i)/dfloat(max(1,npairs(i)-1))/cvar(i,1)
     &                 /cvar(i,2)
        else
          cov(i)=0.0d0
        end if
   30 continue
      write(*,'(a/a/a)')
     2 '-------------- Familial correlations (pairwise) --------------',
     3 'Rel 1   Rel 2    Std Dev 1    Std Dev 2   Correlation  N Pairs',
     4 '--------------------------------------------------------------'
      write(*,'(a,3(1x,f12.4),4x,i5)')
     & 'Husband Wife  ', cvar(1,1),cvar(1,2),cov(1),npairs(1)
      write(*,'(2(a,3(4x,f9.4),4x,i5/a,4x,f9.4,13x,4x,f9.4,4x,i5/))')
     2 'Gparent Gchild', cvar(2,1),cvar(2,2),cov(2),npairs(2),
     3 'Halfsib Hsib  ', cvar(3,1),          cov(3),npairs(3)/2,
     4 'Parent  Off   ', cvar(4,1),cvar(4,2),cov(4),npairs(4),
     5 'Fullsib Fsib  ', cvar(5,1),          cov(5),npairs(5)/2

      write(*,'(a/a)')  'Fain sibship variance test',
     &                  '--------------------------'

      if (nships.gt.2) then
        call alias(r, 6, 3, 1.0d-15, x, ifail)
        call bsub(r, 6, 3, b, 2, ifail)
        call var(r, 6, cov, 6, 3, nships, 1, ifail)
        alpha=b(1)
        sea=sqrt(cov(1))
        beta=b(2)
        seb=sqrt(cov(3))
        tvalb=abs(beta/seb)
        write(*,'(a,i5,2(/a,f10.4,a,f10.4,a)/a,f10.4,a,i3,a,f6.4,a)')
     3    'No. sibships  = ',nships,
     4    'Intercept     = ',alpha,' (ase=',sea,')',
     5    'Slope         = ',beta, ' (ase=',seb,')',
     6    't value       = ',tvalb,' (df=',nships-2,', P=',
     7                       1.0d0-probst(tvalb,nships-2,ifail),')'
      else
        write(*,'(/a/)') 
     &    'NOTE:  Insufficient number of sibships for Fain test.'
      end if
      return
      end
C end-of-famcor
C
C update means and sums of squares and products
C
C 1=Marital 2=Grandparent-Grandchild 3=Half-sib
C 4=Parent-Offspring 5=Full-sib 
C
      subroutine corr(type,x1,x2,npairs,mean,var,cov)
      integer type, npairs(5)
      double precision d1, d2, de, wt, x1,x2
      double precision mean(5,2), var(5,2), cov(5)

      npairs(type)=npairs(type)+1
      de=dfloat(npairs(type))
      wt=(de-1.0d0)/de
      d1=x1-mean(type,1)
      d2=x2-mean(type,2)
      mean(type,1)=mean(type,1)+d1/de
      mean(type,2)=mean(type,2)+d2/de
      var(type,1)=var(type,1)+ d1*d1*wt
      var(type,2)=var(type,2)+ d2*d2*wt
      cov(type)=cov(type)+ d1*d2*wt

      return
      end
C end-of-corr
C
C Means and covariances for multiple trait 
C
      subroutine docov(wrk,nvar,terms,loc,loctyp,locpos,
     2             x,mean,cov,pedigree,actset,num,nfound,id,fa,mo,sex,
     3             locus,numloc,plevel)
C
      integer IBDSIZ, KNOWN, MAXIBD, MAXTER, MAXCOV, MAXSIZ, MAXLOC,MISS
      parameter(KNOWN=0, MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2, 
     2          MAXTER=MAXIBD/2, MAXCOV=MAXTER*(MAXTER+1)/2,
     3          MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer nvar, plevel, wrk
C position of y and x variables
      integer terms(MAXSIZ)
C  Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C
C Locus structure:
C number of loci, locus name, locus type, and locus position in file
C
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)
C array of means and covariances
      double precision x(MAXTER),mean(MAXTER), cov(MAXCOV)
C local variables
      integer i, ifail, ii, j, nobs, ncov, ntot 
      logical complete, last
      double precision den

      if (nvar.gt.(MAXTER)) then
        write(*,'(/a,i3,a/)') 
     &    'NOTE:  May analyse only the first ',MAXTER,' variables.'
        nvar=MAXTER
      end if

      ncov=nvar*(nvar+1)/2
      nobs=0
      ntot=0
      ifail=0
      do 1 i=1, nvar
        mean(i)=0.0d0
    1 continue
      do 2 i=1, ncov
        cov(i)=0.0d0
    2 continue

      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

        do 10 i=1,num
          complete=.true.
          do 12 j=1,nvar
          if ((loctyp(terms(j)).le.2 .and. 
     2         locus(i,locpos(terms(j))).lt.KNOWN) .or.
     3        locus(i,locpos(terms(j))).eq.MISS) then
            complete=.false.
            goto 13
          end if
   12     continue
   13     continue

          if (complete) then
            nobs=nobs+1
            do 14 j=1,nvar
              if (loctyp(terms(j)).le.2) then
                x(j)=0.5d0*dble(locus(i,locpos(terms(j)))+
     &                            locus(i,locpos(terms(j))+1))
              elseif (loctyp(terms(j)).eq.4) then
                x(j)=dble(locus(i,locpos(terms(j)))-1.0)
              else
                x(j)=dble(locus(i,locpos(terms(j))))
              end if
   14       continue
            call dssp(nvar, nobs, 1, x, mean, cov)
          end if
   10   continue
        ntot=ntot+num
      goto 5
   20 continue
C
      den=1.0d0/dfloat(max(1,nobs-1))

      ii=0
      do 50 i=1,nvar
        ii=ii+i
        do 55 j=1,i-1
          cov(ii-i+j)=cov(ii-i+j)/sqrt(cov(ii))/sqrt(cov(j*(j+1)/2))
   55   continue
   50 continue

      write(*,'(/a/a)') 
     2  'Variable        Mean      Stand Dev  Correlations',
     3  '---------- ------------ ------------ ---------------------'
      ii=0
      do 60 i=1,nvar
        ii=ii+i
        write(*,'(a10,1x,f12.4,1x,f12.4,12(1x,f4.2))') 
     2     loc(terms(i)),mean(i),sqrt(cov(ii)*den), 
     3     (cov(ii-i+j),j=1,i-1),1.0d0
   60 continue
      write(*,'(2(/a,i7),a,f5.1,a)') 
     2  'Number of variables     =',nvar,
     3  'No. usable observations =',nobs,
     4  '      ( ',float(100*nobs)/float(ntot),'%)' 
C
      return
      end
C end-of-docov  
C
C linear regression analysis of quantitative trait 
C
      subroutine regress(wrk,twrk,typ,nvar,terms,loc,loctyp,locpos,
     2               x,r,b,cov,pedigree,actset,num,nfound,id,fa,mo,sex,
     3               locus,numloc,plevel)
C
      integer KNOWN, MAXIBD, MAXTER, MAXCOV, MAXSIZ, MAXLOC, MISS
      parameter(KNOWN=0, MAXIBD=1000, MAXTER=MAXIBD/2, 
     2          MAXCOV=MAXTER*(MAXTER+1)/2,
     3          MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer nvar, plevel, twrk, typ, wrk
C position of y and x variables
      integer terms(MAXSIZ)
C  Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C
C Locus structure:
C number of loci, locus name, locus type, and locus position in file
C
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)
C regression work arrays
      double precision x(MAXTER),r(MAXCOV),b(MAXTER),cov(MAXCOV)
C local variables
      integer i,ifail,ii,j,nchange,ncov,nobs,nter,ntot,pos,ypos
      logical complete, fussy, last
C regression results
      integer idf,mdf
      double precision aic,mss,pred,res,rsq,rss,tval
      double precision mean(MAXTER)
      character*3 histo
C functions
      integer eow
      double precision zp

      ypos=terms(nvar)
      write(*,'(/a/3a/a)')
     2  '------------------------------------------------',
     3  'Linear regression analysis of trait "',loc(ypos),'"',
     4  '------------------------------------------------'
      if (nvar.gt.(MAXTER-1)) then
        write(*,'(/a,i3,a/)') 
     &    'NOTE:  May analyse only the first ',MAXTER-1,' variables.'
        nvar=MAXTER-1
      end if

      nobs=0
      ntot=0
      ifail=0
      nter=nvar+1
      ncov=nter*(nter+1)/2
      call inicov(nter, ncov, r)
      do 1 j=1,nvar
        mean(j)=0.0d0
    1 continue

      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
        do 10 i=1,num
          complete=.true.
          do 12 j=1,nvar
          if ((loctyp(terms(j)).le.2 .and. 
     2         locus(i,locpos(terms(j))).lt.KNOWN) .or.
     3        locus(i,locpos(terms(j))).eq.MISS) then
            complete=.false.
            goto 13
          end if
   12     continue
   13     continue

          if (complete) then
            nobs=nobs+1
            x(1)=1.0d0
            do 14 j=1,nvar
              pos=terms(j)
              if (loctyp(pos).le.2) then
                x(j+1)=0.5d0*dble(locus(i,locpos(pos))+
     &                            locus(i,locpos(pos)+1))
              elseif (loctyp(pos).eq.4) then
                x(j+1)=dble(locus(i,locpos(pos))-1.0)
              else
                x(j+1)=dble(locus(i,locpos(pos)))
              end if
              mean(j)=mean(j)+x(j+1)
   14       continue
            call givenc(r, ncov, nter, x, 1.0d0, ifail)
          end if
   10   continue
        ntot=ntot+num
      goto 5
   20 continue

      do 30 j=1, nvar
        mean(j)=mean(j)/dfloat(nobs)
   30 continue
C
      call alias(r, ncov, nter, 1.0d-15, x, ifail)
      call bsub(r, ncov, nter, b, nter-1, ifail)
      call var(r, ncov, cov, ncov, nter, nobs, 1, ifail)
      write(*,'(/a/a)') 
     2  '    Variable         Beta    Stand Error        t-Value',
     3  '  -----------------------------------------------------'
      mdf=0
      mss=0.0d0
      tval=abs(b(1))/sqrt(cov(1))
      call phist(zp(tval),1.0d0,histo)
      write(*,'(2x,a10,1x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') 
     &   'Intercept ',b(1),sqrt(cov(1)), tval, histo
      call sscomp(r, ncov, nter, nobs, 1, rss, idf, ifail)
      ii=1
      do 150 i=2,nter-1
        ii=ii+i
        tval=abs(b(i))/sqrt(cov(ii))
        call phist(zp(tval),1.0d0,histo)
        write(*,'(2x,a10,1x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') 
     &     loc(terms(i-1)),b(i),sqrt(cov(ii)), tval, histo
        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, rss, idf, ifail)
      rsq=1.0d0-rss/(rss+mss)
      mss=mss/dfloat(mdf)
      rss=rss/dfloat(idf)
      aic=log(rss)+2.0d0*dfloat(mdf)/dfloat(nobs)
      write(*,'(/a,i7,a,f5.1,a,2(/a,f12.4,a,i4,a),2(/a,f12.4))') 
     2  'No. usable observations =',nobs,
     3  '      ( ',float(100*nobs)/float(ntot),'%)',
     4  'Model Mean Square       =', mss,' (df=',mdf,')',
     5  'Mean Square Error       =', rss,' (df=',idf,')',
     6  'Multiple R**2           =', rsq,
     7  'Akaike Inf. Criterion   =', aic
C
C Write out residuals or predicted values if requested
C
      if (typ.eq.0) return

      nchange=0
      fussy=(typ.gt.10)
      if (fussy) typ=typ-10

      last=.false.
      rewind(wrk)
   55 continue
        call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &             numloc, last)
      if (last) goto 40
        if (actset.gt.0) then
         do 60 i=1,num
           complete=.true.
           pred=b(1)
           do 65 j=1, nvar-1
             pos=terms(j)
             if (loctyp(pos).le.2) then
               if (locus(i,pos).lt.KNOWN) then
                 complete=.false.
                 res=mean(j)
               else
                 res=0.5d0*dble(locus(i,locpos(pos))+
     &                          locus(i,locpos(pos)+1))
               end if
             elseif (locus(i,pos).eq.MISS) then
               complete=.false.
               res=mean(j)
             elseif (loctyp(pos).eq.4) then
               res=dble(locus(i,locpos(pos))-1.0)
             else
               res=dble(locus(i,locpos(pos)))
             end if
             pred=pred + b(j+1)*res
   65      continue
           if (.not.fussy .or. (fussy .and. complete)) then
             if (typ.eq.1 .and. locus(i,ypos).ne.MISS) then
               nchange=nchange+1
               res=dble(locus(i,locpos(ypos)))-pred
               locus(i,locpos(ypos))=sngl(res) 
             elseif (typ.eq.3 .or. 
     &               (typ.eq.2 .and. locus(i,ypos).eq.MISS)) then
               nchange=nchange+1
               locus(i,locpos(ypos))=sngl(pred) 
             end if
           elseif (typ.eq.1) then 
             locus(i,locpos(ypos))=MISS
           end if
   60    continue
        end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &              locus,numloc)
      goto 55
   40 continue
      if (typ.eq.1) then
        write(*,'(/a,i6,3a)') 'Wrote ',nchange,' residuals to ',
     &    loc(ypos)(1:eow(loc(ypos))),'.'
      else
        write(*,'(/a,i6,3a)') 'Wrote ',nchange,' predicted values to ',
     &    loc(ypos)(1:eow(loc(ypos))),'.'
      end if

      return
      end
C end-of-regress
C
C Fit mixture of distributions to quantitative trait
C
      subroutine domix(wrk,locnam,trait,nmix,typ,pedigree,actset,num,
     &             nfound,id,fa,mo,sex,locus,numloc,value,count,plevel)
C
      integer MAXMIX, MAXSIZ, MAXLOC, MISS, VSIZ
      parameter(MAXMIX=5,MAXSIZ=1000,MAXLOC=120,MISS=-9999,
     &          VSIZ=MAXSIZ*MAXLOC)
      integer nmix, plevel, trait, typ, wrk
      character*10 locnam
C  Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C Quantitative trait values
      integer nobs, nvals
      real value(VSIZ)
      integer count(MAXSIZ)
C Parameter estimates
      real logl
      real alpha(MAXMIX),mean(MAXMIX),sd(MAXMIX) 
C Likelihood contributions
      real prob(MAXSIZ,MAXMIX), den(MAXSIZ)
C local variables
      integer i,ifail,j
      logical last
      real inita,initsd
      character*10 dist(4)
      data dist/'  Normal','Norm: 1 SD','Exponentl',' Poisson'/
C
      nobs=0
      nvals=0

      write(*,'(/a/3a/a)')
     2  '------------------------------------------------',
     3  'Mixture distributions for trait "',locnam,'"',
     4  '------------------------------------------------'

      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 Tabulate sorted values and frequencies
        do 10 i=1,num
        if (locus(i,trait).ne.MISS) then
          nobs=nobs+1
          call qtab(locus(i,trait),nvals,value,count)
        end if
   10   continue
      goto 5
   20 continue
C
C Produce a histogram with HISTCAT intervals
C
      call dohist(min(nvals,21),nvals,value,count,nobs)
      call filliben(nobs,nvals,value,count)
      call symtest(nobs,nvals,value,count)
C
C starting values for mixture
C
      ifail=0
      inita=1.0/float(nmix)
      initsd=sqrt(value(3*nvals/4)-value(nvals/4))
      do 30 i=1,nmix
        alpha(i)=inita
        mean(i)=value(i*nvals/(nmix+1))
        sd(i)=initsd
   30 continue

      call mixture(typ,nmix,nvals,value,count,
     &             alpha,mean,sd,prob,den,nobs,logl,ifail,plevel)

      if (plevel.gt.0) then
        write(*,'(/a/a))') 
     2    ' Rank  Trait value    Obs    Posterior probabilities ',
     3    ' -------------------------------------------------------' 
        do 50 j=1,nvals
          write(*,'(1x,i4,2x,f12.4,i8,5(2x,f5.3):)')
     &      j,value(j),count(j),(alpha(i)*prob(j,i)/den(j),i=1,nmix)
   50   continue
      end if
      if (ifail.ne.0) then
        write(*,'(/a/)') 'ERROR: Problem encountered in estimation.' 
      end if
      write(*,'(/2a,3(/a,i8),/a,f13.4)')
     2  'Distribution type    = ', dist(typ),
     3  'No. of distributions = ', nmix,
     4  'No. of observations  = ', nobs,
     5  'No. of unique values = ', nvals,
     6  '-2*Loglikelihood     = ',-2.0*logl 

      write(*,'(2(/a))')
     2  ' Dist     Mean      Standard Dev  Proportion',
     3  ' -------------------------------------------' 
      do 100 i=1,nmix
        write(*,'(1x,i4,1x,f12.4,2x,f12.4,2x,f6.4)') 
     &    i,mean(i),sd(i),alpha(i)
  100 continue
      return
      end
C end-of-domix
C
C Fit mixture of distributions
C Algorithm AS 203 (Appl Stat 1984; 33:327-332)
C
      subroutine mixture(a,k,m,x,n,alpha,mean,sd,f,g,
     &                   nobs,logl,ifail,plevel)
C
      integer MAXMIX, MAXSIZ
      real TOL
      parameter(MAXMIX=5, MAXSIZ=1000, TOL=1.0d-6)
C
C a=distribution type Nor(k sd) Nor(1 sd) Exp Poi
C k=number of mixture distributions 1..MAXMIX
C m=number of classes 1..MAXSIZ
C
      integer a,k,m,nobs,ifail,plevel
C Parameter estimates
      real logl
      real alpha(MAXMIX),mean(MAXMIX),sd(MAXMIX)
C
C Data: value and number of observations for that value
      integer n(MAXSIZ)
      real x(MAXSIZ)
C Likelihood contributions
      real f(MAXSIZ,MAXMIX), g(MAXSIZ)
C
C Local variables
      logical test
      integer counter
      real oldlogl,part,poolv,poolsd,sumalpha
C Updated estimates
      real nalpha(MAXMIX),nmean(MAXMIX),nsd(MAXMIX),
     &     dt(MAXMIX),nt(MAXMIX),vt(MAXMIX) 
C
      ifail=0
      oldlogl=0.0
      counter=0
      test=.false.
C
C While construct
C
   25 if (test) goto 100 

        if (plevel.gt.2) then
          write(*,'(/a,i5,a,f13.4,a,i2/)') 
     &      'Iter:',counter,' LL:',oldlogl,' Ifail:',ifail
          do 30 j=1,k
            write(*,'(1x,i4,1x,f12.4,2x,f12.4,2x,f6.4)') 
     &        j,mean(j),sd(j),alpha(j)
   30     continue
        end if
        counter=counter+1
        do 40 j=1,k
          if ((alpha(j).gt.1).or.(alpha(j).le.0)) then
            ifail=2
            return
          end if
          if ((mean(j).ge.x(m)).or.(mean(j).le.x(1))) then
            ifail=3
            return
          end if
          if (a.lt.3 .and. sd(j).le.0) then
            ifail=4
            return
          end if
   40   continue
        do 50 i=1,k-1
        do 50 j=i+1,k
          if (mean(i).eq.mean(j)) then
            if (a.lt.3) then
              if (sd(i).eq.sd(j)) then
                ifail=9
                return
              end if
            else
              ifail=8
              return
            end if
          end if
   50   continue
C      
C actual start of EM algorithm a=1-2 Gauss 3 Exp 4 Poisson
C      
        logl=0.0
        do 60 i=1,m
          g(i)=0.0
          do 70 j=1,k
            if (a.eq.3) then
              f(i,j)=exp(-x(i)/mean(j))/mean(j)
            elseif (a.eq.4) then
              if (i.eq.1) then 
                f(i,j)=exp(-mean(j))*mean(j)**x(i)
              else
                f(i,j)=f(i-1,j)*mean(j)**(x(i)-x(i-1))
              end if
            else
              f(i,j)=exp(-0.5*((x(i)-mean(j))/sd(j))**2)/sd(j)
            end if
            g(i)=g(i)+alpha(j)*f(i,j)
   70     continue
          if (g(i).gt.1.0d-25) then
            logl=logl+n(i)*log(g(i))
          end if
   60   continue
C      
C calcs probability densities of the subpopulations which form the
C the mixture, and the loglikelihood function
C      
        test=.true.
        sumalpha=0.0 
C      
        poolv=0.0
        do 80 j=1,k
          nt(j)=0.0
          dt(j)=0.0
          vt(j)=0.0
          do 90 i=1,m
            if (g(i).gt.1.0d-25) then
              part=f(i,j)*n(i)/g(i)
            else
              part=0.0d0
            end if
            dt(j)=dt(j)+part
            nt(j)=nt(j)+part*x(i)
            if (a.lt.3) then 
              vt(j)=vt(j)+part*(x(i)-mean(j))**2
              poolv=poolv+alpha(j)*part*(x(i)-mean(j))**2
            end if
   90     continue
C      
C calc denominators and numerators of new estimates
C      
          nmean(j)=nt(j)/dt(j)
          if (j.ne.k) then
            nalpha(j)=alpha(j)*dt(j)/float(nobs)
            sumalpha=sumalpha+nalpha(j)
          else
            nalpha(k)=1.0-sumalpha
          end if
          if (a.lt.3) then 
            nsd(j)=sqrt(vt(j)/dt(j))
          end if

	  if (abs(oldlogl-logl).gt.TOL) then 
            test= .false.
          end if

          oldlogl=logl
          alpha(j)=nalpha(j)
          mean(j)=nmean(j)
          if (a.lt.3) then 
            sd(j)=nsd(j)
          end if
   80   continue
        if (a.eq.2) then
          poolsd=sqrt(poolv/float(nobs))
          do 82 j=1,k
             sd(j)=poolsd
   82     continue
        end if  
      goto 25
C
C End of While (counter) loop
C
  100 continue
C
C variances for other distributions
C
      if (a.eq.3) then
        do 105 j=1,k
          sd(j)=mean(j)
  105   continue
      elseif (a.eq.4) then
        do 110 j=1,k
          sd(j)=sqrt(mean(j))
  110   continue
      end if

      return
      end
C end-of-mixture
C
C update table of quantitative trait values -- binary search and insertion sort
C 
      subroutine qtab(x,nvals,value,icount)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer nvals
      real value(MAXSIZ), x
      integer icount(MAXSIZ)
      integer hi,lo, pos

      pos=1
      hi=nvals
      lo=1
    1 continue
      if (hi.lt.lo) goto 5
        pos=(hi+lo)/2
        if (x.gt.value(pos)) then
          lo=pos+1
        elseif (x.lt.value(pos)) then
          hi=pos-1
        else
          icount(pos)=icount(pos)+1
          return 
        end if
      goto 1
    5 continue
C 
C else if not found
C
C if enough room, create new category
C
      if (nvals.lt.MAXSIZ) then
        do 25 k=nvals,lo,-1
          value(k+1)=value(k)
          icount(k+1)=icount(k)
   25   continue
        nvals=nvals+1
        value(lo)=x
        icount(lo)=1
C
C else store as average of x and nearest category
C
      else
        value(pos)=value(pos)+(x-value(pos))/float(icount(pos)+1)
        icount(pos)=icount(pos)+1
      end if
      return
      end
C end-of-qtab
C
C update contingency table of trait values -- binary search and insertion sort
C
C ncat=#dimensions, values=data vector, ncells=#cells in table 
C maxcell=max #cells, idx=pointer to label/data for cell,
C icount=count, offset=start of label in workspace, maxcat=workspace
C size, categories=workspace containing all labels/data,
C iwt=contribution of current data vector (usually one)
C 
      subroutine qtabn(ncat,values,ncells,maxcell,idx,icount,
     &                 offset, topcat, maxcat, categories, iwt)
      integer iwt, ncat, offset
      real values(ncat)
C table 
      integer ncells
      integer idx(maxcell),icount(maxcell)
      integer maxcat, topcat
      real categories(maxcat)
C local variables
      integer catpos, endcat, endcell, hi, i, lo, pos

      endcell=offset+ncells

      hi=endcell
      lo=offset+1
      pos=lo
    1 continue
      if (hi.lt.lo) goto 5
        pos=(hi+lo)/2
        catpos=idx(pos)
C test if higher
        do 10 i=1, ncat
          if (values(i).gt.categories(catpos)) then
            lo=pos+1
            goto 1
          else if (values(i).lt.categories(catpos)) then
            goto 11
          end if
          catpos=catpos+1
   10   continue
   11   continue
C test if lower 
        catpos=idx(pos)
        do 20 i=1, ncat
          if (values(i).lt.categories(catpos)) then
            hi=pos-1
            goto 1
          else if (values(i).gt.categories(catpos)) then
            goto 21
          end if
          catpos=catpos+1
   20   continue
   21   continue
C just right
        icount(pos)=icount(pos)+iwt
        return 
C 
C else if not found
C
    5 continue
C
C and if enough room, create new category
C
      endcat=topcat+ncat
      if (endcat.le.maxcat .and. endcell.lt.maxcell) then
        do 25 k=endcell,lo,-1
          idx(k+1)=idx(k)
          icount(k+1)=icount(k)
   25   continue
        ncells=ncells+1
        catpos=topcat+1
        idx(lo)=catpos
        do 50 i=1, ncat
          categories(catpos)=values(i)
          catpos=catpos+1
   50   continue
        icount(lo)=iwt
        topcat=endcat
      else
        write(*,*) 'Too many values for contingency table:'
        write(*,*) (values(i),i=1, ncat), 'n=', iwt
      end if
      return
      end
C end-of-qtabn
C
C
C Binomial regression analysis 
C
      subroutine binreg(wrk,wrk2,twrk,nvar,terms,loc,loctyp,locpos,
     2               x,r,b,cov,pedigree,actset,num,nfound,id,fa,mo,sex,
     3               locus,numloc,plevel)
C
      integer KNOWN, MAXIBD, MAXTER, MAXCOV, MAXSIZ, MAXLOC, MISS
      double precision DELTA, EPS
      parameter(DELTA=1.0d-5, EPS=1.0d-6,
     2          KNOWN=0, MAXIBD=1000, MAXTER=MAXIBD/2, 
     3          MAXCOV=MAXTER*(MAXTER+1)/2,
     4          MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer nvar, plevel, twrk, wrk, wrk2
C position of y and x variables
      integer terms(MAXSIZ)
C  Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C
C Locus structure:
C number of loci, locus name, locus type, and locus position in file
C
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)
C regression work arrays
      double precision x(MAXTER),r(MAXCOV),b(MAXTER),cov(MAXCOV)
C local variables
      integer i,ifail,ii,itmax,j,ncov,nobs,nter,ntot,pos,wrknum,ypos
      character*12 wrkfil
      logical complete, last
      double precision y
C regression results
      integer idf, naff
      double precision base,tval,x2
      character*3 histo
C functions
      double precision zp

      wrknum=1
      wrkfil='sp-log.wrk'
      ypos=terms(nvar)
      write(*,'(/a/3a/a)')
     2  '------------------------------------------------',
     3  'Binom. regression analysis of trait "',loc(ypos),'"',
     4  '------------------------------------------------'
      if (nvar.gt.(MAXTER-1)) then
        write(*,'(/a,i3,a/)') 
     &    'NOTE:  May analyse only the first ',MAXTER-1,' variables.'
        nvar=MAXTER-1
      end if

      naff=0
      nobs=0
      ntot=0
      ifail=0
      idf=nvar-1
      nter=nvar+1
      ncov=nter*(nter+1)/2

      open(twrk,file=wrkfil,form='unformatted')

      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
        do 10 i=1,num
          complete=.true.
          do 12 j=1,nvar
          if ((loctyp(terms(j)).le.2 .and. 
     2         locus(i,locpos(terms(j))).lt.KNOWN) .or.
     3        locus(i,locpos(terms(j))).eq.MISS) then
            complete=.false.
            goto 13
          end if
   12     continue
   13     continue

          if (complete) then
            nobs=nobs+1
            x(1)=1.0d0
            do 14 j=1,nvar
              pos=terms(j)
              if (loctyp(pos).le.2) then
                x(j+1)=0.5d0*dble(locus(i,locpos(pos))+
     &                            locus(i,locpos(pos)+1))
              elseif (loctyp(pos).eq.4) then
                x(j+1)=dble(locus(i,locpos(pos))-1.0)
              else
                x(j+1)=dble(locus(i,locpos(pos)))
              end if
   14       continue
            y=x(nter) 
            if (y.eq.1.0d0) naff=naff+1
            x(nter)=0.25d0*(y-0.5d0)-0.6931472d0
            write(twrk) y, 4.0d0, (x(j), j=1, nter)
          end if
   10   continue
        ntot=ntot+num
      goto 5
   20 continue
      base=dfloat(naff)/dfloat(nobs)
      base=dfloat(naff)*log(base)+dfloat(nobs-naff)*log(1.0d0-base)
      base=-base-base
C
      it=0
      itmax=20
      x2=0.0d0
      oldx2=-1.0d0
  150 continue
      if (it.gt.itmax .or. abs(x2-oldx2).lt.DELTA) goto 50
        it=it+1
        oldx2=x2
        call newnam(wrknum, wrkfil)
        open(wrk2,file=wrkfil,form='unformatted')
        call binirls(twrk,wrk2,nobs,nter,ncov,x2,r,b,y,x,w)
        close(twrk,status='delete')
        close(wrk2,status='keep')
        open(twrk,file=wrkfil,form='unformatted')
        if (plevel.gt.1) then
          write(*,'(i4,a,f16.4)') it, ': ',x2
        end if
      goto 150
   50 continue
      close(twrk,status='delete')

      if (it.gt.itmax) then 
        write(*,'(/a,i4,a/)') 
     &    'NOTE:  Exceeded max (',itmax,') iterations.'
      end if

      call var(r, ncov, cov, ncov, nter, nobs, 2, ifail)
      write(*,'(/a/a)') 
     2  '    Variable         Beta    Stand Error        t-Value',
     3  '  -----------------------------------------------------'
      tval=abs(b(1))/sqrt(cov(1))
      call phist(zp(tval),1.0d0,histo)
      write(*,'(2x,a10,1x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') 
     &   'Intercept ',b(1),sqrt(cov(1)), tval, histo
      ii=1
      do 250 i=2,nter-1
        ii=ii+i
        tval=abs(b(i))/sqrt(cov(ii))
        call phist(zp(tval),1.0d0,histo)
        write(*,'(2x,a10,1x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') 
     &     loc(terms(i-1)),b(i),sqrt(cov(ii)), tval, histo
  250 continue

      write(*,'(/a,i7,a,f5.1,a/a,f12.4/a,i7/a,f12.4,a,i4,a/a,f12.4)') 
     2  'No. usable observations =',nobs,
     3  '      ( ',float(100*nobs)/float(ntot),'%)',
     4  'Null deviance           =', base, 
     5  'Number of iterations    =', it,
     6  'Model LR Chi-square     =', base-x2,' (df=',idf,')',
     7  'Akaike Inf. Criterion   =', dfloat(2*idf)+x2
      return
      end
C end-of-binreg
C
C One iteration of IRLS for binomial regression
C
      subroutine binirls(wrk,wrk2,nobs,nter,nel,x2,r,b,y,x,w)
      integer nter, nel, wrk, wrk2
      double precision r(nel), b(nter), x(nter), x2, y
      double precision EPS
      parameter(EPS=1.0d-6)
      integer i, ifault
      double precision pred, v
C functions
      double precision alogit, logit
      call inicov(nter, nel, r)

      rewind(wrk)
      do 10 i=1, nobs
        read(wrk) y,v,(x(j),j=1, nter)
        call givenc(r, nel, nter, x, v, ifault)
   10 continue
      call alias(r, nel, nter, 1.0d-15, x, ifault)      
      if (ifault.lt.0) then
        write(*,*) 'ERROR: Parameter ',-ifault,' is aliased.'
      end if
      call bsub(r, nel, nter, b, nter, ifault)
      if (ifault.ne.0) write(*,*) 'IRLS Back subst IFAULT=',ifault
      x2=0.0d0
      rewind(wrk)

      do 30 i=1,nobs
        read(wrk) y,v,x
        pred=b(1)
        do 35 j=2,nter-1
          pred=pred+b(j)*x(j)
   35   continue
        pred=alogit(pred)
        v=1.0d0/pred/(1.0d0-pred)
        z=y-pred
        x(nter)=logit(pred)+z*v
        if (pred.gt.EPS .and. (1.0d0-pred).gt.EPS) then
          if (y.eq.1.0d0) then
            x2=x2-log(pred)
          else
            x2=x2-log(1.0d0-pred)
          end if
        end if
        write(wrk2) y, v, (x(j), j=1, nter)
   30 continue
      x2=x2+x2
      return
      end
C end-of-binirls
