
C
C Calculate variances for a given SML model
C
      subroutine qtlpars(p,m1,m2,m3,sd1,sd2,sd3)

      double precision m1,m2,m3, p, sd1, sd2, sd3
      double precision expx, iqr, h2, midp, mu,q, sd, va,vd,ve,vt

      q=1.0d0-p
      mu=p*p*m1+2*q*p*m2+q*q*m3
      va=2*p*q*(p*(m1-m2)+q*(m2-m3))**2
      vd=p*p*q*q*(m1-2*m2+m3)**2

      ve=p*p*sd1*sd1 + 2*p*q*sd2*sd2 + q*q*sd3*sd3
      vt=va+vd+ve
      sd=sqrt(vt)
      h2=(va+vd)/vt

      write(*,'(/a,f5.3/a/a,3(4x,f5.3,4x),2(/a,3(1x,f12.6)))')
     2  'A allele frequency       = ', p, 
     3  'Genotypes                =      A/A         A/B          B/B',
     4  'Genotype frequencies     = ', p*p, 2*p*q, q*q,
     5  'Genotypic means          =', m1,  m2,  m3,
     6  'Genotypic SDs            =', sd1, sd2, sd3
      write(*,'(/a,f12.6,a,f12.6,a/a,3(1x,f12.6)/a,5x,f5.3)')
     2   'Expected trait mean (SD) = ', mu, ' (',sd,')',
     3   'Variances (A, D, E)      =', va, vd, ve,
     4   'Broad heritability       =', h2 
      midp=mu-4*sd
      h2=va/vt
      iqr=0.67449d0*vt*(1.0d0-0.5d0*h2*h2)
      write(*,'(/a/a)') '   Midparent    E(Child)        Expected IQR',
     &  ' ----------- ------------ -------------------------'
      do 10 i=1,7
        midp=midp+sd
        expx= mu+h2*(midp-mu)
        write(*,'(f12.4,3(1x,f12.4))') midp, expx, expx-iqr, expx+iqr
   10 continue

      return
      end
C end-of-qtlpars
C
C Calculate penetrances for a particular prevalence and genotypic RR
C
      subroutine grrpen(model,prev,q,grr)
      character*3 model
      double precision grr, prev, q 
      double precision f1,f2,f3,p,r

      r=1.0d0/grr
      p=1.0d0-q
C recessive
      if (model.eq.'rec') then
        f1 = prev/((q*(q+(2.0d0*p*r)))+(p*p*r))
        f2 = r*f1
        f3 = f2
C additive
      else if (model.eq.'add') then
        f1 = prev/((q*(q+(2.0d0*p*r)))+((p*r)**2))
        f2 = r*f1
        f3 = r*f2
C dominant 
      else 
        f1 = prev/((q*(q+(p+p)))+((p*p)*r))
        f2 = f1
        f3 = r * f1
      end if
      if (f1.lt.0.0d0) f1=0.0d0
      if (f2.lt.0.0d0) f2=0.0d0
      if (f3.lt.0.0d0) f3=0.0d0
      if (f1.gt.1.0d0) f1=1.0d0
      if (f2.gt.1.0d0) f2=1.0d0
      if (f3.gt.1.0d0) f3=1.0d0
      call recrisk(q,f1,f2,f3)
      return
      end
C end-of-grrpen
C
C Calculate recurrence risks and risk ratios for given SML model
C
      subroutine recrisk(q,f1,f2,f3)

      double precision f1,f2,f3, p, q, qa, qu
      integer rel,ii,jj
      double precision i(3,3),t(3,3),o(3,3),r(3,3),a(3),b(3)
      double precision ci(4),ct(4),co(4),riska(4),risku(4),rr(4)
      double precision ff(3),kp,kq,va,vd,oddsr(4),mating(3),pap
      data ci /1.0, 0.25, 0.0, 0.0/
      data ct /0.0, 0.5 , 1.0, 0.5/
      data co /0.0, 0.25, 0.0, 0.5/

      p=1.0d0-q
      kp=q*q*f1+2.0d0*p*q*f2+p*p*f3
      kq=1.0d0-kp
      qa=(q*q*f1+q*(1-q)*f2)/kp
      qu=(q*q*(1.0d0-f1)+q*p*(1.0d0-f2))/kq
      a(1)=q*q*f1/kp
      a(2)=2*p*q*f2/kp
      a(3)=p*p*f3/kp
      b(1)=q*q*(1.0d0-f1)/kq
      b(2)=2*p*q*(1.0d0-f2)/kq
      b(3)=p*p*(1.0d0-f3)/kq
      do 10 rel=1,4
        do 20 ii=1,3
        do 20 jj=1,3
          i(ii,jj)=0.0d0
          t(ii,jj)=0.0d0
   20   continue
        do 30 ii=1,3
          i(ii,ii)=1.0d0
          o(ii,1)=q*q
          o(ii,2)=2.0d0*q*p
          o(ii,3)=p*p
   30   continue
        t(1,1)=q
        t(3,2)=q
        t(1,2)=p
        t(3,3)=p
        t(2,1)=0.5d0*q
        t(2,2)=0.5d0
        t(2,3)=0.5d0*p
        do 40 ii=1, 3
        do 40 jj=1, 3
          i(ii,jj)=i(ii,jj)*ci(rel)
          t(ii,jj)=t(ii,jj)*ct(rel)
          o(ii,jj)=o(ii,jj)*co(rel)
          r(ii,jj)=i(ii,jj)+t(ii,jj)+o(ii,jj)
   40   continue
        riska(rel)=0.0d0
        risku(rel)=0.0d0
        ff(1)=f1*r(1,1)+f2*r(1,2)+f3*r(1,3)
        ff(2)=f1*r(2,1)+f2*r(2,2)+f3*r(2,3)
        ff(3)=f1*r(3,1)+f2*r(3,2)+f3*r(3,3)
        do 60 ii=1,3
          riska(rel)=riska(rel)+ff(ii)*a(ii)
          risku(rel)=risku(rel)+ff(ii)*b(ii)
   60   continue     
        if (risku(rel).le.0.0d0) then
          rr(rel)=9999.9d0
          oddsr(rel)=9999.9d0
        else 
          if (riska(rel)/risku(rel).gt.10000.0d0) then
            rr(rel)=9999.9d0
            oddsr(rel)=9999.9d0
          else
            rr(rel)=riska(rel)/risku(rel)
            oddsr(rel)=riska(rel)/(1.0d0-riska(rel))*
     &                 (1.0d0-risku(rel))/risku(rel)
          end if
        end if
   10 continue
      va=2*q*p*(q*(f1-f2)+p*(f2-f3))**2
      vd=q*q*p*p*(f1-2.0d0*f2+f3)**2
      mating(1)=qu*qu*f1+2.0d0*(1.0d0-qu)*qu*f2+(1.0d0-qu)*(1.0d0-qu)*f3
      mating(2)=qa*qu*f1+((1.0d0-qu)*qa+
     &                    (1.0d0-qa)*qu)*f2+(1.0d0-qa)*(1.0d0-qu)*f3
      mating(3)=qa*qa*f1+2.0d0*(1.0d0-qa)*qa*f2+(1.0d0-qa)*(1.0d0-qa)*f3
      pap=100.d0*(1.0d0-min(f1,f2,f3)/kp)

      write(*,993) q,f1,f2,f3
      write(*,994) kp,pap,va,vd
      write(*,995)
      write(*,996) 'Rec risk',riska(1),riska(2),riska(3),riska(4),
     2 'Rel risk',rr(1),rr(2),rr(3),rr(4),
     3 'Odds rat',oddsr(1),oddsr(2),oddsr(3),oddsr(4),
     4 'PRR     ',riska(1)/kp,riska(2)/kp,riska(3)/kp,riska(4)/kp  
      write(*,996) 'ibd|A-A ',1.0,0.25*(riska(1)+riska(3))/riska(2),
     2  0.5,0.5*riska(3)/(riska(3)+kp),
     3 'ibd|A-U ',1.0,(0.5-0.25*(riska(1)+riska(3)))/(1.0-riska(2)),
     4  0.5,(0.25-0.25*riska(3))/(1.0-riska(4))
      write(*,997) qa, q*q*f1/kp, 2.0*q*(1.0-q)*f2/kp,
     2             (1.0-q)*(1.0-q)*f3/kp,
     3             qu, q*q*(1.0-f1)/kq, 2.0*q*(1.0-q)*(1.0-f2)/kq, 
     4             (1.0-q)*(1.0-q)*(1.0-f3)/kq
      write(*,998) (1.0-kp)**2,mating(1),2.0*kp*(1.0-kp),
     &             mating(2),kp*kp,mating(3)
  993 format(/1x,'Frequency(A): ',f8.6,'; Pen(AA): ',f5.3,
     &           '; Pen(AB): ',f5.3,'; Pen(BB): ',f5.3)
  994 format( 1x,'Trait Prev  : ',f8.6,'; Pop AR: ',f5.1,
     &           '%; Var(Add): ',f8.6,'; Var(Dom): ',f8.6)
  995 format(/1x,'Measure      MZ Twin       Sib-Sib        Par-Off  ',
     2           '    Second    '/
     3           '----------   ----------    ----------     ---------',
     4           '    ----------')
  996 format((1x,a8,2x,4(1x,f11.3,2x)))
  997 format(/1x,'Freq of A if Affected: ',f8.6,
     2  ' (',f5.3,',',f5.3,',',f5.3,') '/1x,'Freq of A if Unaffctd: ',
     3  f8.6,' (',f5.3,',',f5.3,',',f5.3,')')
  998 format(/1x,'Mating       Proportion    Risk to offspring'/
     2           '----------   -----------   ------------------ '/
     3        'UnA x UnA',2x,2(1x,f11.3,2x)/
     4        'Aff x UnA',2x,2(1x,f11.3,2x)/
     5        'Aff x Aff',2x,2(1x,f11.3,2x))
      return
      end
C end-of-recrisk
C
C Produce a histogram with histcat intervals from sorted tabulation
C
      subroutine dohist(histcat,nvals,value,count,nobs)
      integer histcat
      integer nobs, nvals
      real value(nvals)
      integer count(nvals)
C
      integer cum, histcnt, histscale, i, j, n, oldcum
      integer stats(3)
      character*1 ch
      real histwidth,midval,upper
C
      stats(1)=nobs/4
      stats(2)=nobs/2
      stats(3)=3*nobs/4
      histscale=max(1,nobs/100)
      histwidth=(value(nvals)-value(1))/float(histcat)
      histcnt=0
      cum=0
      oldcum=0
      n=0
      i=1
      upper=value(1)+histwidth
      write(*,'(/a/a)') 
     2    ' Intvl Midpt  Count   Histogram',
     3    ' -------------------------------------------------------' 
   20 continue
        if (value(i).le.upper) then
          histcnt=histcnt+count(i)
          n=n+1
          i=i+1
        else
          cum=cum+histcnt
          if (n.eq.1) then
            midval=value(i-1)
          else
            midval=upper-0.5*histwidth 
          end if
          if (oldcum.le.stats(2) .and. cum.ge.stats(2)) then
            ch='+'
          elseif (oldcum.le.stats(3) .and. cum.ge.stats(1)) then
            ch='|'
          else
            ch=' '
          end if
          write(*,'(f12.4,1x,i6,x,a1,x,50a:)') midval,
     &      histcnt,ch,('*',j=1,min(50,histcnt/histscale))
          upper=upper+histwidth
          histcnt=0
          n=0
          oldcum=cum
        end if
      if (i.le.nvals) goto 20

      if (n.eq.1) then
        midval=value(i-1)
      else
        midval=upper-0.5*histwidth 
      end if
      write(*,'(f12.4,1x,i6,3x,50a:/)') midval,
     &  histcnt,('*',j=1,min(50,histcnt/histscale))
      return
      end
C end-of-dohist
C
C Filliben correlation here testing for normality
C
C   m(i) = 1 - m(n) for i = 1
C   m(i) = (i - 0.3175)/(n + 0.365) for i = 2, 3, ..., n-1
C   m(i) = 0.5**(1/n) for i = n
C
      subroutine filliben(nobs,nvals,value,count)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer nobs, nvals, count(MAXSIZ)
      real value(MAXSIZ)
C local variables
      integer i, n
      double precision cov(3), den, dn, mean(2), p, r, x(2)
C functions
      double precision ppnd, zp

      mean(1)=0.0d0
      mean(2)=0.0d0
      cov(1)=0.0d0
      cov(2)=0.0d0
      cov(3)=0.0d0
      n=count(1)
      dn=dfloat(nobs)
      x(1)=ppnd(1.0d0-0.5d0**(1.0d0/dn))
      x(2)=dble(value(1))
      call dssp(2, n, count(1), x, mean, cov)
      den=1.0d0/(0.365d0+dn)
      do 10 i=2, nvals-1
        n=n+count(i)
        x(1)=ppnd(den*(dfloat(i) - 0.3175d0))
        x(2)=dble(value(i))
        call dssp(2, n, count(i), x, mean, cov)
   10 continue
      n=n+count(nvals)
      x(1)=ppnd(0.5d0**(1.0d0/dn))
      x(2)=dble(value(nvals))
      call dssp(2, n, count(nvals), x, mean, cov)

      r=cov(2)/sqrt(cov(1))/sqrt(cov(3))
C
C Approximate P-value modelled on that for Royston 1993 for W'
C
      p=log(1.0d0-r)+1.99196d0+1.0402d0*(log(dn)-log(log(dn)))
      p=zp(p/(0.31239d0+0.788392d0/log(dn)))
      write(*,'(/a,f13.4,a,f5.3,a)')
     &  'Filliben correlation = ', r, ' (P=',p,')'
      return
      end
C end-of-filliben
C
C David & Johnson's Jr test for symmetry of a distribution
C Resek Busi Stat 1975; 546-551
C Doksum Biometrika 1977; 64: 473-487
C 
C Standard error of Jr based on simulations under Gaussian true distribution
C
      subroutine symtest(nobs,nvals,value,count)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer nobs, nvals, count(MAXSIZ)
      real value(MAXSIZ)
C local variables
      integer i, n, nstat, pos(5)
      double precision dn,j02,x(5)
C functions
      double precision zp

      dn=dfloat(nobs)
      pos(1)=nint(0.02d0*dn)
      pos(2)=nint(0.25d0*dn)
      pos(3)=nint(0.50d0*dn)
      pos(4)=nint(0.75d0*dn)
      pos(5)=nint(0.98d0*dn)
      n=0
      nstat=1
      do 10 i=1, nvals
        n=n+count(i)
        if (n.ge.pos(nstat)) then
          x(nstat)=dble(value(i))
          nstat=nstat+1
          if (nstat.gt.5) goto 11
        end if
   10 continue
   11 continue
      j02=(0.5d0*(x(1)+x(5))-x(3))/(x(4)-x(2))
      write(*,'(a,f13.4,a,f5.3,a)') 'Symmetry test J(.02) = ',
     &  j02,' (P=',zp(0.735d0*sqrt(dn)*abs(j02)),')'
      return
      end
C end-of-symtest
C
C calculate McNemar statistic
C
       double precision function clcmcn(b,c)
       integer b,c
       clcmcn=0.0d0
       if ((b+c).gt.0) then
         clcmcn=dfloat((b-c)*(b-c))/dfloat(b+c)
       end if
       return
       end
C end-of-clcmcn
C
C normal approx binomial deviate
C
      double precision function binz(x,n,e)
      integer x,n
      double precision e
      binz=0.0d0
      if (e.ne.0.0d0 .and. e.ne.1.0d0 .and. n.gt.1) then
        binz=(dfloat(x)-dfloat(n)*e)/sqrt(e*(1.0d0-e)*dfloat(n-1))
      end if
      return
      end 
C end-of-binz
C
C Freeman-Tukey deviates
C
      double precision function ftdev(o,e)
      double precision o,e
      ftdev=sqrt(o)+sqrt(o+1.0d0)-sqrt(4.0d0*e+1.0d0)
      return
      end 
C end-of-ft
C
C find index of coefficient for pair i,j in 1-D array
C
      integer function clcpos(i,j)
      integer i,j
      if (i.gt.j) then
        clcpos=i*(i-1)/2+j
      else
        clcpos=j*(j-1)/2+i
      end if
      return
      end
C end-of-clcpos
C
C Initialize array with value of index
C
      subroutine ascend(n, ia)
      integer n
      integer ia(*)
      do 10 i=1,n
        ia(i)=i
   10 continue
      return
      end
C end-of-ascend
C
C Copy integer array A to integer array B
C
      subroutine copy(n, ia, ib)
      integer n
      integer ia(*), ib(*)
      do 10 i=1,n
        ib(i)=ia(i)
   10 continue
      return
      end
C end-of-copy
C
C Load a lower triangular matrix 
      subroutine filltri(n,nn,a,dval,oval)
      integer n, nn
      double precision a(nn), dval, oval
      integer i,j
      do 10 i=1, nn
        a(i)=oval
   10 continue
      if (dval.ne.oval) then
        j=0
        do 20 i=1, n
          j=j+i
          a(j)=dval
   20   continue
      end if
      return
      end
C end-of-filltri
C
C Binary search for position of value in an ascending sorted array
C
      subroutine match(ival,num,key,pos)
      integer ival, pos, num
      integer key(*)
      
      integer hi, lo

      hi=num
      lo=1
   10 continue
        pos=(hi+lo)/2
        if (ival.gt.key(pos)) then
          lo=pos+1
        elseif (ival.lt.key(pos)) then
          hi=pos-1
        else
          return
        end if
      if (hi.ge.lo) goto 10
        pos=0
      return
      end
C end-of-match
C
C Evaluate (y-m)' S (y-m) where S is symmetric lower triangular matrix
C
      subroutine quadmult(n,x,m,nn,c,w1,w2,res)
      integer n, nn
      double precision res
      double precision c(nn), m(n), w1(n), w2(n), x(n)
      integer i,j,pos, k

      do 10 i=1, n
        w1(i)=x(i)-m(i)
   10 continue
      pos=0
      do 20 i=1, n
        w2(i)=0.0d0
        do 30 j=1, i-1
          w2(i)=w2(i)+w1(j)*c(pos+j)
   30   continue
        k=pos
        do 40 j=i,n
          w2(i)=w2(i)+w1(j)*c(k+i)
          k=k+j
   40   continue
        pos=pos+i
   20 continue
      res=0.0d0
      do 50 i=1, n
        res=res+w2(i)*w1(i)
   50 continue
      return
      end
C end-of-quadmult
C
C  Invert real symmetric positive-definite matrix using
C  AS 7 Applied Stat 1968; 17:198
C  Reads in and returns a lower triangular matrix.
C
      subroutine syminv(a,n,nn,c,w, logdet, nullty,ifault)

      double precision a(nn),c(nn),w(n),logdet,x,zero,one
      data zero,one /0.0d0,1.0d0/
C
      logdet=0.0d0
      call chol(a,n,nn,c,nullty,ifault)
      if (ifault.ne.0) return

      l=0
      do 5 i=1, n
        l=l+i
        logdet=logdet+log(c(l))
    5 continue
      logdet=logdet+logdet

      irow=n
      ndiag=nn
   10 l=ndiag
      if (c(ndiag).eq.zero) goto 60
      do 20 i=irow,n
        w(i)=c(l)
        l=l+i
   20 continue
      icol=n
      jcol=nn
      mdiag=nn
   30 l=jcol
      x=zero
      if (icol.eq.irow) x=one/w(irow)
      k=n
   40 if (k.eq.irow) goto 50
        x=x-w(k)*c(l)
        k=k-1
        l=l-1
        if (l.gt.mdiag) l=l-k+1
        goto 40
   50 c(l)=x/w(irow)
      if (icol.eq.irow) goto 80
      mdiag=mdiag-icol
      icol=icol-1
      jcol=jcol-1
      goto 30
C
   60 do 70 j=irow,n
        c(l)=zero
        l=l+j
   70 continue
   80 ndiag=ndiag-irow
      irow=irow-1
      if (irow.ne.0) goto 10
      return
      end
C end-of-syminv
C
C AS 6 Appl Stat 1968; 17:195
C
      subroutine chol(a,n,nn,u,nullty,ifault)
      double precision a(nn),u(nn),eta,eta2,x,w,zero,zabs,zsqrt
      data eta,zero /1.0e-15, 0.0/
      zabs(x)=abs(x)
      zsqrt(x)=sqrt(x)
C
      ifault=1
      if (n.le.0) return
      ifault=3
      if (nn.ne.n*(n+1)/2) return
      ifault=2
      nullty=0
      j=1
      k=0
      eta2=eta*eta
      i1=0
      do 80 icol=1,n
        i1=i1+icol
        x=eta2*a(i1)
        l=0
        kk=0
        do 40 irow=1,icol
          kk=kk+irow
          k=k+1
          w=a(k)
          m=j
          do 10 i=1,irow
            l=l+1
            if (i.eq.irow) goto 20
            w=w-u(l)*u(m)
            m=m+1
   10     continue
   20     if (irow.eq.icol) goto 50
           if (u(l).eq.zero) goto 30
           u(k)=w/u(l)
           goto 40
C
   30     if(w*w.gt.zabs(x*a(kk))) return
           u(k)=zero
   40     continue
   50 if (zabs(w).le.zabs(eta*a(k))) goto 60
      if (w.lt.zero) return
      u(k)=zsqrt(w)
      goto 70
C
   60 u(k)=zero
      nullty=nullty+1
   70 j=j+icol
   80 continue
      ifault=0
      return
      end
C end-of-chol
C
C SLATEC quicksort routine for character key.  Jones, Kahaner and Wisniewski.
C The options to sort descending and not reorder the second array have been 
C removed, and argument order changed.
C
      subroutine csort(n, cx, iy)
      integer n
      character*8 cx(*)  
      integer iy(*)
C local variables
      real r
      character*8 t, tt
      integer i, ij, j, k, l, m, nn, ty, tty
      integer il(21), iu(21)

      nn = n
      if (nn .lt. 1) return
C
C Sort CX and carry IY along
C
  100 m = 1
      i = 1
      j = nn
      r = 0.375e0
C
  110 if (i .eq. j) go to 150
      if (r .le. 0.5898437e0) then
         r = r+3.90625e-2
      else
         r = r-0.21875e0
      endif
C
  120 k = i
C
C Select a central element of the array and save it in location T
C
      ij = i + int((j-i)*r)
      t = cx(ij)
      ty = iy(ij)
C
C If first element of array is greater than T, interchange with T
C
      if (cx(i) .gt. t) then
         cx(ij) = cx(i)
         cx(i) = t
         t = cx(ij)
         iy(ij) = iy(i)
         iy(i) = ty
         ty = iy(ij)
      endif
      l = j
C
C If last element of array is less than T, interchange with T
C
      if (cx(j) .lt. t) then
         cx(ij) = cx(j)
         cx(j) = t
         t = cx(ij)
         iy(ij) = iy(j)
         iy(j) = ty
         ty = iy(ij)
C
C If first element of array is greater than T, interchange with T
C
         if (cx(i) .gt. t) then
            cx(ij) = cx(i)
            cx(i) = t
            t = cx(ij)
            iy(ij) = iy(i)
            iy(i) = ty
            ty = iy(ij)
         endif
      endif
C
C Find an element in the second half of the array which is smaller
C than T
C
  130 l = l-1
      if (cx(l) .gt. t) go to 130
C
C Find an element in the first half of the array which is greater
C than T
C
  140 k = k+1
      if (cx(k) .lt. t) go to 140
C
C Interchange these elements
C
      if (k .le. l) then
         tt = cx(l)
         cx(l) = cx(k)
         cx(k) = tt
         tty = iy(l)
         iy(l) = iy(k)
         iy(k) = tty
         go to 130
      endif
C
C Save upper and lower subscripts of the array yet to be sorted
C
      if (l-i .gt. j-k) then
         il(m) = i
         iu(m) = l
         i = k
         m = m+1
      else
         il(m) = k
         iu(m) = j
         j = l
         m = m+1
      endif
      go to 160
C
C Begin again on another portion of the unsorted array
C
  150 m = m-1
      if (m .eq. (1-1)) return
      i = il(m)
      j = iu(m)
C
  160 if (j-i .ge. 1) go to 120
      if (i .eq. 1) go to 110
      i = i-1
C
  170 i = i+1
      if (i .eq. j) go to 150
      t = cx(i+1)
      ty = iy(i+1)
      if (cx(i) .le. t) go to 170
      k = i
C
  180 cx(k+1) = cx(k)
      iy(k+1) = iy(k)
      k = k-1
      if (t .lt. cx(k)) go to 180
      cx(k+1) = t
      iy(k+1) = ty
      go to 170
C
      end
C end-of-csort
C
C SLATEC quicksort routine.  Jones, Kahaner and Wisniewski.
C The option to sort descending has been removed, the argument order 
C changed, and the sort is now from bot...top, rather than 1...top.
C
      subroutine isort(bot, top, ix, iy, kflag)
      integer kflag, bot, top
      integer ix(*), iy(*)
C local variables
      real r
      integer i, ij, j, k, l, m, nn, t, tt, ty, tty
      integer il(21), iu(21)

      nn = top
      if (nn .lt. bot) return
C
      if (kflag .eq. 2) go to 100
C
C Sort IX only
C
      m = 1
      i = bot
      j = nn
      r = 0.375e0
C
   20 if (i .eq. j) go to 60
      if (r .le. 0.5898437e0) then
         r = r+3.90625e-2
      else
         r = r-0.21875e0
      endif
C
   30 k = i
C
C Select a central element of the array and save it in location T
C
      ij = i + int((j-i)*r)
      t = ix(ij)
C
C If first element of array is greater than T, interchange with T
C
      if (ix(i) .gt. t) then
         ix(ij) = ix(i)
         ix(i) = t
         t = ix(ij)
      endif
      l = j
C
C If last element of array is less than than T, interchange with T
C
      if (ix(j) .lt. t) then
         ix(ij) = ix(j)
         ix(j) = t
         t = ix(ij)
C
C If first element of array is greater than T, interchange with T
C
         if (ix(i) .gt. t) then
            ix(ij) = ix(i)
            ix(i) = t
            t = ix(ij)
         endif
      endif
C
C Find an element in the second half of the array which is smaller
C than T
C
   40 l = l-1
      if (ix(l) .gt. t) go to 40
C
C Find an element in the first half of the array which is greater
C than T
C
   50 k = k+1
      if (ix(k) .lt. t) go to 50
C
C Interchange these elements
C
      if (k .le. l) then
         tt = ix(l)
         ix(l) = ix(k)
         ix(k) = tt
         go to 40
      endif
C
C Save upper and lower subscripts of the array yet to be sorted
C
      if (l-i .gt. j-k) then
         il(m) = i
         iu(m) = l
         i = k
         m = m+1
      else
         il(m) = k
         iu(m) = j
         j = l
         m = m+1
      endif
      go to 70
C
C Begin again on another portion of the unsorted array
C
   60 m = m-1
      if (m .eq. 0) return
      i = il(m)
      j = iu(m)
C
   70 if (j-i .ge. 1) go to 30
      if (i .eq. 1) go to 20
      i = i-1
C
   80 i = i+1
      if (i .eq. j) go to 60
      t = ix(i+1)
      if (ix(i) .le. t) go to 80
      k = i
C
   90 ix(k+1) = ix(k)
      k = k-1
      if (t .lt. ix(k)) go to 90
      ix(k+1) = t
      go to 80
C
C Sort IX and carry IY along
C
  100 m = 1
      i = bot
      j = nn
      r = 0.375e0
C
  110 if (i .eq. j) go to 150
      if (r .le. 0.5898437e0) then
         r = r+3.90625e-2
      else
         r = r-0.21875e0
      endif
C
  120 k = i
C
C Select a central element of the array and save it in location T
C
      ij = i + int((j-i)*r)
      t = ix(ij)
      ty = iy(ij)
C
C If first element of array is greater than T, interchange with T
C
      if (ix(i) .gt. t) then
         ix(ij) = ix(i)
         ix(i) = t
         t = ix(ij)
         iy(ij) = iy(i)
         iy(i) = ty
         ty = iy(ij)
      endif
      l = j
C
C If last element of array is less than T, interchange with T
C
      if (ix(j) .lt. t) then
         ix(ij) = ix(j)
         ix(j) = t
         t = ix(ij)
         iy(ij) = iy(j)
         iy(j) = ty
         ty = iy(ij)
C
C If first element of array is greater than T, interchange with T
C
         if (ix(i) .gt. t) then
            ix(ij) = ix(i)
            ix(i) = t
            t = ix(ij)
            iy(ij) = iy(i)
            iy(i) = ty
            ty = iy(ij)
         endif
      endif
C
C Find an element in the second half of the array which is smaller
C than T
C
  130 l = l-1
      if (ix(l) .gt. t) go to 130
C
C Find an element in the first half of the array which is greater
C than T
C
  140 k = k+1
      if (ix(k) .lt. t) go to 140
C
C Interchange these elements
C
      if (k .le. l) then
         tt = ix(l)
         ix(l) = ix(k)
         ix(k) = tt
         tty = iy(l)
         iy(l) = iy(k)
         iy(k) = tty
         go to 130
      endif
C
C Save upper and lower subscripts of the array yet to be sorted
C
      if (l-i .gt. j-k) then
         il(m) = i
         iu(m) = l
         i = k
         m = m+1
      else
         il(m) = k
         iu(m) = j
         j = l
         m = m+1
      endif
      go to 160
C
C Begin again on another portion of the unsorted array
C
  150 m = m-1
      if (m .eq. 0) return
      i = il(m)
      j = iu(m)
C
  160 if (j-i .ge. 1) go to 120
      if (i .eq. 1) go to 110
      i = i-1
C
  170 i = i+1
      if (i .eq. j) go to 150
      t = ix(i+1)
      ty = iy(i+1)
      if (ix(i) .le. t) go to 170
      k = i
C
  180 ix(k+1) = ix(k)
      iy(k+1) = iy(k)
      k = k-1
      if (t .lt. ix(k)) go to 180
      ix(k+1) = t
      iy(k+1) = ty
      go to 170
C
      end
C end-of-isort
C
C inverse Haldane (mapf=1) or Kosambi (mapf=2) mapping x cM->r
C
      real function invmap(x,mapf)
      integer mapf
      real x

      if (mapf.eq.1) then
        invmap=0.5*(1.0-exp(-0.02*abs(x)))
      elseif (mapf.eq.2) then
        invmap=0.5*(exp(0.04*abs(x))-1)/(exp(0.04*abs(x))+1)
      else
        invmap=x
      end if
      if (invmap.lt.0.001) invmap=0.001
      return
      end
C end-of-invmap
C
C Factorial
C
      double precision function fact(n)
      integer i,n
      double precision lookup(0:20)
      data lookup /1.0d0,1.0d0,2.0d0,6.0d0,2.4d1,1.2d2,7.2d2,5.04d3,
     2             4.032d4,3.6288d5,3.6288d6,3.99168d7,4.790016d8,
     3             6.2270208d9,8.71782912d10,1.307674368d12,
     4             2.0922789888d13,3.55687428096d14,6.402373705728d15,
     5             1.21645100408832d17,2.43290200817664d18/
      if (n.lt.21) then
        fact=lookup(n)
      else
        fact=lookup(20)
        do 10 i=21,n
          fact=fact*dfloat(i)
   10   continue
      end if
      return
      end
C end-of-fact
C
C Calculate Bonferroni corrected P-value for given number of tests
C
      double precision function bonf(ntest,alpha)
      integer ntest
      double precision alpha
      bonf=alpha
      if (ntest.gt.1) then
        bonf=1.0d0-(1.0d0-alpha)**(1.0d0/dfloat(ntest))
      end if
      return
      end
C end-of-bonf
C 
C Confidence intervals around a proportion: approach of Wilson (Agresti
C & Coull)
C
      subroutine propci(num, den, width)
      integer num, den
      real width
      double precision alpha, ll, phat, rtot, t1, t2, t3, ul, z, z2
C functions
      double precision ppnd

      if (width.le.0.0 .or. width.ge.100.0) width=95.0
      alpha=(1.0d0-0.01d0*dble(width))
      z=ppnd(0.5d0*alpha)
      z2=z*z
      rtot=1.0d0/dfloat(den)
      phat=dfloat(num)*rtot
      t1=rtot*0.5d0*z2
      t2=z * sqrt((phat * (1.0d0 - phat) + 0.25*rtot*z2)*rtot)
      t3=1.0d0+rtot*z2
      ll=(phat+t1 + t2)/t3
      ul=(phat+t1 - t2)/t3
      if (num.eq.1) ll= -log(1.0d0-alpha)*rtot
      if ((den-num).eq.1) ul= 1 + log(1 - alpha)*rtot

      write(*,'(a,f8.6,1x,i2,a,f8.6,a,f8.6)') 
     2  'Prop=',phat, int(width), '%CI=', ll, ' -- ', ul
      return
      end
C end-of-propci
C
C Binomial probabilities for x,n-x with p=0.5
C
      double precision function binp(np,nq)
      double precision np, nq
      integer i
      double precision a,b,bt
C Functions
      double precision alngam, betacf
      if (np.eq.nq) then
        binp=1.0d0
        return
      end if
      if (np.gt.nq) then
        a=np
        b=nq+1.0d0
      else
        a=nq
        b=np+1.0d0
      end if
      bt=dexp(alngam(a+b,i)-alngam(a,i)-alngam(b,i)+(a+b)*dlog(0.5d0))
      binp=bt*betacf(a,b,0.5d0)/a
C two-tailed P
      binp=binp+binp
      if (binp.gt.1.0d0) binp=1.0d0
      return
      end
C end-of-binp
C
C betacf from Numerical Recipes, 1986
C
      double precision function betacf(a,b,x)

      double precision a,b,x,qab,qap,qam,eps
      double precision bz,d,ap,bp,app,bpp,am,bm,az,aold,tem,em
      parameter (itmax=100,eps=3.0d-7)
      am=1.0d0
      bm=1.0d0
      az=1.0d0
      qab=a+b
      qap=a+1.0d0
      qam=a-1.0d0
      bz=1.0d0-qab*x/qap
      do 11 m=1,itmax
        em=m
        tem=em+em
        d=em*(b-m)*x/((qam+tem)*(a+tem))
        ap=az+d*am
        bp=bz+d*bm
        d=-(a+em)*(qab+em)*x/((a+tem)*(qap+tem))
        app=ap+d*az
        bpp=bp+d*bz
        aold=az
        am=ap/bpp
        bm=bp/bpp
        az=app/bpp
        bz=1.0d0
        if (dabs(az-aold).lt.eps*dabs(az)) goto 1
   11 continue
      write(*,'(a/)') 'ERROR: In betacf().'
    1 betacf=az
      return
      end
C end-of-betacf
C
C Evaluate central chi-square in FORTRAN
C
      double precision function chip(chisq,df)
      double precision chisq
      integer df
      integer ifault
C functions
      double precision gammad

      if (df.le.0 .or. chisq.le.0.0d0) then
         chip=1.0d0
         return
      end if
      chip=1.0d0-gammad(0.5d0*chisq, 0.5d0*dfloat(df), ifault)
      return
      end
C end-of-chip
C
C Algorithm AS239  Appl. Statist. (1988) Vol. 37, No. 3
C
C Computation of the Incomplete Gamma Integral
C
        double precision function gammad(x, p, ifault)
C
        integer ifault
        double precision pn1, pn2, pn3, pn4, pn5, pn6, x, tol, oflo,
     *          xbig, arg, c, rn, p, a, b, one, zero, alngam, zp,
     *          an, two, elimit, plimit, three, nine
        parameter (zero = 0.d0, one = 1.d0, two = 2.d0, oflo = 1.d+37,
     *          three = 3.d0, nine = 9.d0, tol = 1.d-14, xbig = 1.d+8,
     *          plimit = 1000.d0, elimit = -88.d0)
        external alngam, zp
C
        gammad = zero
C
C       Check that we have valid values for X and P
C
C       if (p .le. zero .or. x .lt. zero) then
C         ifault = 1
C         return
C       end if
C       ifault = 0
C       if (x .eq. zero) return
C
C       Use a normal approximation if P > PLIMIT
C
        if (p .gt. plimit) then
          pn1 = three * sqrt(p) * ((x / p) ** (one / three) + one /
     *          (nine * p) - one)
          gammad = 1.0d0-zp(pn1)
          return
        end if
C
C       If X is extremely large compared to P then set GAMMAD = 1
C
        if (x .gt. xbig) then
          gammad = one
          return
        end if
C
        if (x .le. one .or. x .lt. p) then
C
C       Use Pearson's series expansion.
C       (Note that P is not large enough to force overflow in ALNGAM).
C       No need to test IFAULT on exit since P > 0.
C
          arg = p * log(x) - x - alngam(p + one, ifault)
          c = one
          gammad = one
          a = p
   40     a = a + one
          c = c * x / a
          gammad = gammad + c
          if (c .gt. tol) go to 40
          arg = arg + log(gammad)
          gammad = zero
          if (arg .ge. elimit) gammad = exp(arg)
C
        else
C
C       Use a continued fraction expansion
C
          arg = p * log(x) - x - alngam(p, ifault)
          a = one - p
          b = a + x + one
          c = zero
          pn1 = one
          pn2 = x
          pn3 = x + one
          pn4 = x * b
          gammad = pn3 / pn4
   60     a = a + one
          b = b + two
          c = c + one
          an = a * c
          pn5 = b * pn3 - an * pn1
          pn6 = b * pn4 - an * pn2
          if (abs(pn6) .gt. zero) then
            rn = pn5 / pn6
            if (abs(gammad - rn) .le. min(tol, tol * rn)) go to 80
            gammad = rn
          end if
C
          pn1 = pn3
          pn2 = pn4
          pn3 = pn5
          pn4 = pn6
          if (abs(pn5) .ge. oflo) then
C
C       Re-scale terms in continued fraction if terms are large
C
            pn1 = pn1 / oflo
            pn2 = pn2 / oflo
            pn3 = pn3 / oflo
            pn4 = pn4 / oflo
          end if
          go to 60
   80     arg = arg + log(gammad)
          gammad = one
          if (arg .ge. elimit) gammad = one - exp(arg)
        end if
C
        return
        end
C end-of-gammad (AS239)
C
C ALGORITHM AS245  APPL. STATIST. (1989) VOL. 38, NO. 2
C
C Calculation of the logarithm of the gamma function
C
      double precision function alngam(xvalue, ifault)
      integer ifault
      double precision alr2pi, four, half, one, onep5, r1(9), r2(9),
     +          r3(9), r4(5), twelve, x, x1, x2, xlge, xlgst, xvalue,
     +          y, zero
C
C     Coefficients of rational functions
C
      data r1/-2.66685 51149 5d0, -2.44387 53423 7d1,
     +        -2.19698 95892 8d1,  1.11667 54126 2d1,
     +         3.13060 54762 3d0,  6.07771 38777 1d-1,
     +         1.19400 90572 1d1,  3.14690 11574 9d1,
     +         1.52346 87407 0d1/
      data r2/-7.83359 29944 9d1, -1.42046 29668 8d2,
     +         1.37519 41641 6d2,  7.86994 92415 4d1,
     +         4.16438 92222 8d0,  4.70668 76606 0d1,
     +         3.13399 21589 4d2,  2.63505 07472 1d2,
     +         4.33400 02251 4d1/
      data r3/-2.12159 57232 3d5,  2.30661 51061 6d5,
     +         2.74647 64470 5d4, -4.02621 11997 5d4,
     +        -2.29660 72978 0d3, -1.16328 49500 4d5,
     +        -1.46025 93751 1d5, -2.42357 40962 9d4,
     +        -5.70691 00932 4d2/
      data r4/ 2.79195 31791 8525d-1, 4.91731 76105 05968d-1,
     +         6.92910 59929 1889d-2, 3.35034 38150 22304d0,
     +         6.01245 92597 64103d0/
C
C     Fixed constants
C
      data alr2pi/9.18938 53320 4673d-1/, four/4.d0/, half/0.5d0/,
     +     one/1.d0/, onep5/1.5d0/, twelve/12.d0/, zero/0.d0/
C
C     Machine-dependant constants.
C     A table of values is given at the top of page 399 of the paper.
C     These values are for the IEEE double-precision format for which
C     B = 2, t = 53 and U = 1023 in the notation of the paper.
C
      data xlge/5.10d6/, xlgst/1.d+305/
C
      x = xvalue
      alngam = zero
C
C     Test for valid function argument
C
      ifault = 2
      if (x .ge. xlgst) return
      ifault = 1
      if (x .le. zero) return
      ifault = 0
C
C     Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined
C
      if (x .lt. onep5) then
        if (x .lt. half) then
          alngam = -log(x)
          y = x + one
C
C     Test whether X < machine epsilon
C
          if (y .eq. one) return
        else
          alngam = zero
          y = x
          x = (x - half) - half
        end if
        alngam = alngam + x * ((((r1(5)*y + r1(4))*y + r1(3))*y
     +                + r1(2))*y + r1(1)) / ((((y + r1(9))*y + r1(8))*y
     +                + r1(7))*y + r1(6))
        return
      end if
C
C     Calculation for 1.5 <= X < 4.0
C
      if (x .lt. four) then
        y = (x - one) - one
        alngam = y * ((((r2(5)*x + r2(4))*x + r2(3))*x + r2(2))*x
     +              + r2(1)) / ((((x + r2(9))*x + r2(8))*x + r2(7))*x
     +              + r2(6))
        return
      end if
C
C     Calculation for 4.0 <= X < 12.0
C
      if (x .lt. twelve) then
        alngam = ((((r3(5)*x + r3(4))*x + r3(3))*x + r3(2))*x + r3(1)) /
     +            ((((x + r3(9))*x + r3(8))*x + r3(7))*x + r3(6))
        return
      end if
C
C     Calculation for X >= 12.0
C
      y = log(x)
      alngam = x * (y - one) - half * y + alr2pi
      if (x .gt. xlge) return
      x1 = one / x
      x2 = x1 * x1
      alngam = alngam + x1 * ((r4(3)*x2 + r4(2))*x2 + r4(1)) /
     +              ((x2 + r4(5))*x2 + r4(4))
      return
      end
C end-of-alngam (AS245)
C
C Algorithm AS66 Applied Statistics (1973) vol22 no.3
C
C Evaluates the tail area of the standardised normal curve
C       from x to infinity if up is .true. or
C       from minus infinity to x if up is .false.
C
      double precision function zp(x)
      double precision zero,one,half
      double precision con,z,y,x
      double precision p,q,r,a1,a2,a3,b1,b2,c1,c2,c3,c4,c5,c6
      double precision d1,d2,d3,d4,d5
      logical up
C* machine dependent constants
      double precision ltone,utzero
      data zero/0.0d0/, one/1.0d0/, half/0.5d0/
      data ltone/7.0d0/,utzero/18.66d0/
      data con/1.28d0/
      data p/0.398942280444d0/,q/0.39990348504d0/,r/0.398942280385d0/
      data a1/5.75885480458d0/,a2/2.62433121679d0/,a3/5.92885724438d0/
      data b1/-29.8213557807d0/,b2/48.6959930692d0/
      data c1/-3.8052d-8/,c2/3.98064794d-4/,c3/-0.151679116635d0/
      data c4/4.8385912808d0/,c5/0.742380924027d0/,c6/3.99019417011d0/
      data d1/1.00000615302d0/,d2/1.98615381364d0/,d3/5.29330324926d0/
      data d4/-15.1508972451d0/,d5/30.789933034d0/
C
      up=.true.
      z=x
      if (z.ge.zero) goto 10
        up=.not.up
        z=-z
   10 if (z.le.ltone .or. up .and. z.le.utzero) goto 20
        zp=zero
        goto 40
   20 y=half*z*z
      if (z.gt.con) goto 30
c
      zp=half-z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
      goto 40
   30 zp=r*dexp(-y)/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/
     2   (z+c6))))))
   40 if (.not.up) zp=one-zp
      return
      end
C end-of-zp (AS66)
C
C Algorithm AS 111, Appl.Statist., vol.26, 118-121, 1977.
C Produces normal deviate corresponding to lower tail area = p.
C
        double precision function ppnd(p)
        double precision p, q, r
        double precision a0, a1, a2, a3, b1, b2, b3, b4,
     &                   c0, c1, c2, c3, d1, d2, split
        double precision half, one, zero

        data split/0.42d0/
        data a0,a1,a2,a3/2.50662823884d0,-18.61500062529d0,
     1  41.39119773534d0,-25.44106049637d0/, b1,b2,b3,b4/
     2  -8.47351093090d0,23.08336743743d0,-21.06224101826d0,
     3  3.13082909833d0/, c0,c1,c2,c3/-2.78718931138d0,-2.29796479134d0,
     4  4.85014127135d0,2.32121276858d0/, d1,d2/3.54388924762d0,
     5  1.63706781897d0/
        data zero/0.d0/, one/1.d0/, half/0.5d0/
C
        q = p-half
        if (abs(q).gt.split) go to 10
C
C       0.08 < p < 0.92
C
        r = q*q
        ppnd = q*(((a3*r + a2)*r + a1)*r + a0)/((((b4*r + b3)*r + b2)*r
     1          + b1)*r + one)
        return
C
C       p < 0.08 or p > 0.92, set r = min(p,1-p)
C
   10   r = p
        if (q.gt.zero) r = one-p
        if (r.le.zero) go to 20
        r = sqrt(-log(r))
        ppnd = (((c3*r + c2)*r + c1)*r + c0)/((d2*r + d1)*r + one)
        if (q.lt.zero) ppnd = -ppnd
        return
   20   continue
        ppnd = zero
        return
        end
C end-of-ppnd (AS111)
C
C Algorithm AS 3  Appl. Statist. (1968) vol.17, p.189
C student t probability (lower tail)
C
      double precision function probst(t, idf, ifault)
      integer idf, ifault, im2, ioe
      double precision a, b, c, f, g1, s, fk, t, zero, 
     &                 one, two, half, zsqrt, zatan
C
C g1 is reciprocal of pi
      data zero, one, two, half, g1
     &     /0.0d0, 1.0d0, 2.0d0, 0.5d0, 0.3183098861838d0/
C
      zsqrt(a) = sqrt(a)
      zatan(a) = atan(a)
C
      ifault = 1
      probst = zero
      if (idf .lt. 1) return
      ifault = 0
      f = idf
      a = t / zsqrt(f)
      b = f / (f + t ** 2)
      im2 = idf - 2
      ioe = mod(idf, 2)
      s = one
      c = one
      f = one
      ks = 2 + ioe
      fk = ks
      if (im2 .lt. 2) goto 20
      do 10 k = ks, im2, 2
      c = c * b * (fk - one) / fk
      s = s + c
      if (s .eq. f) goto 20
      f = s
      fk = fk + two
   10 continue
   20 if (ioe .eq. 1) goto 30
      probst = half + half * a * zsqrt(b) * s
      return
   30 if (idf .eq. 1) s = zero
      probst = half + (a * b * s + zatan(a)) * g1
      return
      end
C end-of-probst (AS3)
C
C accumulate mean and sum-of-squares following AS41
C
      subroutine moment(n,x,mean,ss)
      integer n
      double precision mean, ss, x
C local variables
      double precision dev

      dev=x-mean
      mean=mean+dev/dfloat(n)
      ss=ss+dev*dev*dfloat(n-1)/dfloat(n)
      return
      end
C end-of-moment
C
C accumulate means and SSCP following AS41
C
      subroutine dssp(nvar, nobs, iwt, x, mean, cov)
      integer iwt, nobs, nvar
      double precision cov(*), mean(*), x(*)
C local variables
      integer i,j,k
      double precision b, c
      b=dfloat(iwt)/dfloat(nobs)
      c=dfloat(iwt)-b
      k=0
      do 10 i=1, nvar
        x(i)=x(i)-mean(i)
        mean(i)=mean(i)+b*x(i)
        do 15 j=1, i
          k=k+1
          cov(k)=cov(k)+c*x(i)*x(j)
   15   continue
   10 continue
      return
      end
C end-of-dssp
C
C Initialize covariance matrix used by AS164
C
      subroutine inicov(nter, ncov, r)
      integer ncov, nter
      double precision r(ncov)
C
      call filltri(nter,ncov,r,-1.0d0,0.0d0)
      return
      end
C end-of-inicov
C
C Algorithm AS164  Appl. Statist. (1981) vol.30, no.2
C Incorporate new row of data into R matrix
C
      subroutine givenc(r, ir, nvars, x, v, ifault)
      double precision zero, eps0, eps1
      parameter(zero=0.0d0, eps0=0.0d0, eps1=0.0d0)
      integer ifault, ir, nvars
      double precision r(ir), x(nvars), v
C
      integer i, ii, ij, iplus, j
      double precision c, ctemp, rtemp, s, vlocal, vnew, xi, xi2
C
      ifault = 0
      irused = nvars*(nvars+1)/2
      if (ir.lt.irused) go to 1003
      if (v.lt.zero) go to 1002
      vlocal = v
C
C for each row of upper triangular r
C
      ii = 0
      do 60 i = 1, nvars
        ii = ii + i
        xi = x(i)
        xi2 = xi*xi
        if (xi2.le.abs(vlocal)*eps0) go to 60
        ctemp = r(ii)
        ij = ii
        iplus = i + 1
C
C if zero weight on row of r, simple pivot
C
        if (ctemp.ge.zero) go to 20
        r(ii) = vlocal/xi2
        if (i.eq.nvars) go to 70
        do 10 j = iplus, nvars
          ij = ij + j - 1
          r(ij) = x(j)/xi
   10   continue
        return
C
C if infinite weight on row of r, simple pivot
C
   20   if (ctemp.gt.eps1) go to 40
        do 30 j = iplus, nvars
          ij = ij + j - 1
          x(j) = x(j) - xi*r(ij)
   30   continue
        go to 60
C
C otherwise ordinary givens rotation
C
   40   vnew = vlocal + ctemp*xi2
        c = vlocal/vnew
        s = ctemp*xi/vnew
        vlocal = vnew
        r(ii) = ctemp*c
        if (i.eq.nvars) go to 70
        do 50 j = iplus, nvars
          ij = ij + j - 1
          rtemp = c*r(ij) + s*x(j)
          x(j) = x(j) - xi*r(ij)
          r(ij) = rtemp
   50   continue
C
   60 continue
C
C check for inconsistent or duplicated constraints
C
   70 if (abs(r(irused)).le.eps1) go to 1001
      if (vlocal.le.eps1) ifault = -1
      return
C
C error flag set
C
 1001 ifault = ifault + 1
 1002 ifault = ifault + 1
 1003 ifault = ifault + 1
      return
      end
C end-of-givenc (AS164)
C
C Algorithm AS 164.1  Appl. Statist. (1981) vol.30, no.2
C Perform back substitution to get regression coefficient estimates
C
      subroutine bsub(r, ir, idep, coeff, ic, ifault)
      double precision zero
      parameter(zero=0.0d0)
      integer ic,idep,ifault,ir
      double precision r(ir), coeff(ic)
C
      integer i,ii,ij,k,nx,nxvars
      double precision temp
C
      ifault = 0
      ii = idep*(idep+1)/2
      nxvars = idep - 1
      if (ir.lt.ii.or.ic.lt.nxvars) go to 1001
      if (nxvars.lt.1) return
C
C back substitution
C
      k = ii
      nx = idep
      do 30 i = 1, nxvars
        ii = ii - nx
        k = k - 1
        temp = r(k)
        if (r(ii).lt.zero) ifault = ifault - 1
        if (i.eq.1) go to 20
        ij = ii
        do 10 j = nx, nxvars
          ij = ij + j - 1
          temp = temp - r(ij)*coeff(j)
   10   continue
   20   nx = nx - 1
        coeff(nx) = temp
   30 continue
      return
C
 1001 ifault = 1
      return
      end
C end-of-bsub (AS164.1)
C
C Algorithm AS 164.2  Appl. Statist. (1981) Vol.30, No.2
C Finds (icomp)th component of total sum of sqrs
C Zero-th component is residual ssq
C
C
      subroutine sscomp(r, ir, idep, nobs, icomp, ssq, idf, ifault)
      integer icomp, idf, ifault, idep, ir, nobs
      double precision r(ir), ssq
C local variables
      integer i, ii, ij, nxvars
      double precision one, zero
      data zero/0.0d0/, one/1.0d0/
C
C Small constant that the user can modify
C
      data eps1/0.0d0/
C
C Check for valid parameters
C
      ifault = 0
      irused = idep*(idep + 1)/2
      if (ir.lt.irused) ifault = ifault + 1
      if (icomp.lt.0.or.icomp.ge.idep) ifault = ifault + 2
      if (ifault.gt.0) return
C
C Test if residual ssq required
C
      if (icomp.ge.1) go to 20
      nxvars = idep - 1
      idf = nobs - nxvars
      ii = 0
      do 10 i = 1, nxvars
        ii = ii + i
        if (r(ii).le.eps1) idf = idf + 1
   10 continue
      ssq = zero
      if (r(irused).gt.eps1) ssq = one/r(irused)
      return
C
C Ordinary component
C
   20 idf = 0
      ssq = zero
      ii = icomp*(icomp+1)/2
      if (r(ii).le.eps1) return
      idf = 1
      ij = irused - idep + icomp
      ssq = r(ij)*r(ij)/r(ii)
      return
      end
C end-of-sscomp
C
C Algorithm AS164.3  Appl. Statist. (1981) vol.30, no.2
C Estimates var/covar matrix of regression coefficients
C
      subroutine var(r, ir, s, is, idep, nobs, typ, ifault)
      double precision zero, one, eps1
      parameter(zero=0.0d0, one=1.0d0, eps1=0.0d0)
      integer idep, ifault, ir, is, nobs, typ
      double precision r(ir), s(is)
C
      integer idf, ij, irused, j, jj, k, ki, kj, kk, kmax,kmin, nxvars
      double precision sigma, stemp
C
C check for valid parameters
C
      ifault = 0
      irused = idep*(idep+1)/2
      if (ir.lt.irused.or.is.lt.(irused-idep)) go to 1002
      nxvars = idep - 1
C
C invert unit upper triangular matrix
C
      ncons = 0
      ij = 0
      do 50 i = 1, nxvars
        jj = 0
        j = 0
   10   j = j + 1
        ij = ij + 1
        jj = jj + j
        if (j.lt.i) go to 20
        if (r(ij).le.eps1) ncons = ncons + 1
        go to 50
   20   stemp = -r(ij)
        ik = ij
        kj = jj
        kmax = i - 1
        kmin = j + 1
        if (kmax.lt.kmin) go to 40
        do 30 k = kmin, kmax
          ik = ik + 1
          kj = kj + k - 1
          stemp = stemp - r(ik)*s(kj)
   30   continue
   40   s(ij) = stemp
        go to 10
   50 continue
C
C estimate variance and apply identifiability constraints
C
      idf = nobs - nxvars + ncons
      if (idf.le.0) go to 1001
      sigma = zero
      if (r(irused).gt.zero) then
        if (typ.eq.1) then
          sigma = one/(r(irused)*dfloat(idf))
        else
          sigma = one
        end if
      end if
      ii = 0
      do 60 i = 1, nxvars
        ii = ii + i
        s(ii) = sigma*r(ii)
        if (r(ii).lt.zero) s(ii) = zero
   60 continue
C
C multiply matrices together to form est of var
C
      ii = 0
      ij = 0
      do 90 i = 1, nxvars
        ii = ii + i
        do 90 j = 1, i
          kk = ii
          ij = ij + 1
          ki = ij
          kj = ii
          stemp = s(kk)
          if (i.ne.j) stemp = stemp*s(ij)
          k = i
   70     k = k + 1
          if (k.gt.nxvars) go to 80
          kk = kk + k
          ki = ki + k - 1
          kj = kj + k - 1
          stemp = stemp + s(ki)*s(kj)*s(kk)
          go to 70
C
   80     s(ij) = stemp
   90 continue
      return
C
 1001 ifault = ifault + 1
 1002 ifault = ifault + 1
      return
      end
C end-of-var (AS164.3)
C
C Algorithm AS164.4  Appl. Statist. (1981) vol.30, no.2
C Assumes any diagonal elements of d less than eps are
C Rounding errors and reduces them to zero
C
      subroutine alias(r, ir, nvars, eps, worksp, ifault)
      double precision zero, one, oneneg
      parameter(zero=0.0d0, one=1.0d0, oneneg=-1.0d0)
C
      integer ifault,ir,nvars
      double precision eps, r(ir), worksp(nvars)
C local
      integer i,ii,ij,iplus,irused, nxvars
      double precision v
C
C check for valid parameters
C
      ifault = 0
      irused = nvars*(nvars+1)/2
      if (ir.lt.irused) go to 1001
      nxvars = nvars - 1
C
C for each row of triangular r
C
      ii = 0
      do 20 i = 1, nxvars
        ii = ii + i
        worksp(i) = zero
C
C check for weight of row near zero
C
        if (abs(r(ii))*eps.le.one) go to 20
        ifault = ifault - 1
        v = r(ii)
        r(ii) = oneneg
        ij = ii
        iplus = i + 1
C
C rotate modified row with givens
C
        do 10 j = iplus, nvars
          ij = ij + j - 1
          worksp(j) = r(ij)
          r(ij) = zero
   10   continue
        call givenc(r, ir, nvars, worksp, v, ifail)
   20 continue
      return
C
C set fault indicator
C
 1001 ifault = 1
      return
      end
C end-of-alias (AS164.4)
C
C Use AS164 to fit a log-linear model
C
      subroutine loglin(ncells,totpars,npars,count,model,
     &              x,r,b,cov,lrts)
      integer MAXIBD, MAXTER, MAXCOV
      double precision DELTA, EPS
      parameter(DELTA=1.0d-5, EPS=1.0d-6, MAXIBD=1000,
     &          MAXTER=MAXIBD/2, MAXCOV=MAXTER*(MAXTER+1)/2)
      integer ncells, npars, totpars
      
      real count(*), model(*)
      double precision lrts
C
C regression work arrays
      double precision x(MAXTER),r(MAXCOV),b(MAXTER),cov(MAXCOV)
      double precision eta(MAXTER), weight(MAXTER)
C local variables
      integer ifail, it, ncov, nter, pos
      double precision obs, oldx2, pred

      ifail=0
      nter=npars+1
      ncov=nter*(nter+1)/2
      nobs=0
      do 1 i=1, ncells
        eta(i)=log(dble(count(i))+0.5d0)
        weight(i)=1.0d0/(dble(count(i))+0.5d0)
        nobs=nobs+int(count(i))
    1 continue

      it=0
      lrts=-1.0d0
    5 continue
        it=it+1
        oldx2=lrts
        call inicov(nter, ncov, r)
        do 10 i=1, ncells
          pos=(i-1)*totpars
          do 15 j=1,npars 
            pos=pos+1
            x(j)=dble(model(pos))
   15     continue
          x(nter)=eta(i)
          call givenc(r, ncov, nter, x, weight(i), ifail)
   10   continue
        call alias(r, ncov, nter, 1.0d-15, x, ifail)
        call bsub(r, ncov, nter, b, npars, ifail)
        lrts=0.0d0
        do 30 i=1,ncells
          pred=0.0d0
          pos=(i-1)*totpars
          do 35 j=1,npars
            pos=pos+1
            pred=pred+b(j)*dble(model(pos))
   35     continue
          pred=exp(pred)
          obs=dble(count(i))
          eta(i)=log(pred)+(obs-pred)/pred
          if (obs.gt.EPS .and. pred.gt.EPS) lrts=lrts+obs*log(obs/pred)
          weight(i)=1.0d0/pred
   30   continue
      if (it.lt.50 .and. abs(lrts-oldx2).gt.DELTA) goto 5

      call alias(r, ncov, nter, 1.0d-15, x, ifail)
      call bsub(r, ncov, nter, b, npar, ifail)
      call var(r, ncov, cov, ncov, nter, nobs, 2, ifail)

      return
      end
C end-of-loglin
C
C logit of p
      double precision function logit(p)
      double precision p
      if (p.le.0.00000001d0) then
        logit=-18.42068073d0
      elseif (p.gt.0.99999999d0) then
        logit=+18.42068073d0
      else
        logit=log(p)-log(1-p)
      end if
      return
      end
C end-of-logit
C
C reverse logit
      double precision function alogit(x)
      double precision x
      alogit=exp(x)/(1+exp(x))
      return
      end
C end-of-alogit
C
C  The function RANDN() returns a normally distributed pseudo-random
C  number with zero mean and unit variance.  Calls are made to a
C  function subprogram RANDOM() which returns independent random
C  numbers uniform in the interval (0,1).
C
C  The algorithm uses the ratio of uniforms method of A.J. Kinderman
C  and J.F. Monahan augmented with quadratic bounding curves.
C
        real function randn()
        real a,b,r1,r2,s,t
C functions
        real random
        data s,t,a,b / 0.449871, -0.386595, 0.19600, 0.25472/
        data r1,r2/ 0.27597, 0.27846/

C
C  Generate P = (u,v) uniform in rectangle enclosing acceptance region
 50     u = random()
        v = random()
        v = 1.7156 * (v - 0.5)
C  Evaluate the quadratic form
        x  = u - s
        y  = abs(v) - t
        q  = x**2 + y*(a*y - b*x)
C  Accept P if inside inner ellipse
        if (q .lt. r1) go to 100
C  Reject P if outside outer ellipse
        if (q .gt. r2) go to 50
C  Reject P if outside acceptance region
        if (v**2 .gt. -4.0*log(u)*u**2) go to 50
C  Return ratio of P's coordinates as the normal deviate
 100    randn = v/u
        return
        end
C end-of-randn
C
C Return a pseudo-random integer from integer U(lo..hi)
C
      integer function irandom(lo,hi)
      integer lo,hi
C functions
      real random
      irandom=lo+int(float(hi-lo+1)*random())
      if (irandom.gt.hi) irandom=hi
      return      
      end
C end-of-irandom
C
C Algorithm AS 183 Appl Stat 1982; 31:188
C Returns a pseudo-random number from U(0,1)
C
C ix,iy,iz should be "randomly" initialised to 1-30000
C eg via time 
C
      real function random()
      integer ix,iy,iz
      common /rndseed/ ix,iy,iz 
      ix=171*mod(ix,177)-2*(ix/177)
      iy=172*mod(iy,176)-35*(iy/176)
      iz=170*mod(iz,178)-63*(iz/178)
C
      if (ix.lt.0) ix=ix+30269
      if (iy.lt.0) iy=iy+30307
      if (iz.lt.0) iz=iz+30323
C
      random=amod(float(ix)/30269.0+float(iy)/30307.0 +
     :		  float(iz)/30323.0,1.0)
      return
      end
C end-of-random (AS183)
C
C end-of-program
