
C
C Variance components analysis 
C
      subroutine sibqtl(wrk,twrk,tranam,trait,locnam,gene,pedigree,
     2                  actset,num, nfound,id,fa,mo,sex,locus,numloc,
     3              numal,name,alfrq, untyped,set,a,c,plevel)
      integer KNOWN,MAXALL,IBDSIZ,MAXIBD,NPAR,MAXSIZ,MAXLOC,MISS
      parameter (KNOWN=0, MAXALL=60,MAXSIZ=1000,MAXLOC=120,MAXPAR=4,
     &           MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2, MISS=-9999)
C
      integer MAXFN
      double precision GRADTL
      parameter (GRADTL = 1.0d-12, MAXFN = 1000)
C
      integer gene,trait,twrk,wrk,plevel
      character*10 locnam, tranam
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 allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C Array to contain covariances and inverse
      double precision a(IBDSIZ), c(IBDSIZ)
C work arrays
      integer set(MAXSIZ,2)
      logical untyped(MAXSIZ)
      double precision x(MAXPAR), w(MAXPAR*(MAXPAR+5))
      double precision m(MAXSIZ),w1(MAXSIZ),w2(MAXSIZ),y(MAXSIZ)
C local variables
      integer currf, currm, fin, gen2, i, i1, i2, i3, i4, ier, iter,
     &        j, k, nn, pos, sibs, tot, typ
      character*3 histo
      logical last
      double precision aelik, asyp, aqelik, d2, lod, ymean, yvar
C functions
      integer getnam
      double precision chip

      if (plevel.gt.0) then
        write(*,'(/a/a,a10,a,a10,a/a)') 
     2  '-----------------------------------------------------',
     3  'VC linkage analysis for "',tranam,'" v "' ,locnam,'"',
     4  '-----------------------------------------------------' 
      end if

      gen2=gene+1
      last=.false.
      nfam=0
      npar=4
      sibs=0
      tot=0 
      typ=2
      ymean=0.0d0
      yvar=0.0d0
      rewind(wrk)
    5 continue
        call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &             numloc, last)
        if (last) goto 20
C
        if (actset.le.0) goto 5
C
        do 70 i=1,num
        if (locus(i,gene).gt.KNOWN) then
          untyped(i)=.false.
          set(i,1)=getnam(locus(i,gene),numal,name)
          set(i,2)=getnam(locus(i,gen2),numal,name)
        else  
          untyped(i)=.true.
          set(i,1)=MISS
          set(i,2)=MISS
        end if
   70   continue
C
C Full sibs
C
        fin=num
        currf=fa(fin)
        currm=mo(fin)
        do 90 k=num-1,nfound,-1
          if (fa(k).ne.currf .or. mo(k).ne.currm) then
            nobs=0
            do 92 i=k+1,fin
            if (locus(i,trait).ne.MISS .and. .not.untyped(i)) then 
              nobs=nobs+1
              tot=tot+1
              y(nobs)=dble(locus(i,trait))
              call moment(tot,y(nobs),ymean,yvar)
            end if
   92       continue
C
C Skip if no usable individuals in this sibship
C else reduce ibd matrix to that for phenotyped individuals only
C
            if (nobs.gt.0) then
              nfam=nfam+1
              sibs=sibs+nobs*(nobs-1)/2
C kinships
              call filltri(nobs,nobs*(nobs+1)/2,c,1.0d0,0.5d0)
C ibds
              call nucibd(gene,currf,currm,k+1,fin,set,
     &                untyped, a, numal, name, alfrq)
              nn=0
              pos=0
              do 60 i=k+1,fin
                do 65 j=k+1,i
                  pos=pos+1
                  if (locus(i,trait).ne.MISS .and. .not.untyped(i) .and.
     &                locus(j,trait).ne.MISS .and. .not.untyped(j)) then
                    nn=nn+1
                    a(nn)=a(pos)
                  end if
   65           continue
   60         continue
C     pos=0
C     do kk=1, nobs
C       write(*,'(i2,1x,f8.4,100(1x,f6.4):)') kk,y(kk),(a(pos+i),i=1,kk)
C       pos=pos+kk
C     end do
              write(twrk) nobs, nn, (y(i),i=1,nobs), 
     &                    (c(i), i=1, nn), (a(i),i=1, nn)
            end if
C Now update to next sibship
            fin=k
            currf=fa(fin)
            currm=mo(fin)
          end if
   90   continue
C
      goto 5
   20 continue
C
C plug in starting values and iterate for MLEs
C
      if (sibs.eq.0) return

      yvar=yvar/dfloat(tot)

      npar=3
      x(1)=ymean
      x(2)=0.1d0*yvar
      x(3)=0.9d0*yvar
C
      aelik=0.0d0
      typ=1
      call initvm(npar, i1,i2,i3,i4, ier)
      call varmet(npar,x,aelik,w(i3),w,w(i1),w(i2),w(i4),
     &       gradtl,maxfn,ier,iter,twrk,typ,y,a,c,m,w1,w2,plevel)
      if (ier.ne.0) call vmerr(ier, maxfn)

      call mvnlik(twrk,typ,npar,x,y,a,aelik,c,m,w1,w2)

      npar=4
      typ=2
      x(4)=abs(x(3))
      x(3)=0.1d0*abs(x(2))
      x(2)=0.9d0*abs(x(2))
      aqelik=0.0d0
      call initvm(npar, i1,i2,i3,i4, ier)
      call varmet(npar,x,aqelik,w(i3),w,w(i1),w(i2),w(i4),
     &       gradtl,maxfn,ier,iter,twrk,typ,y,a,c,m,w1,w2,plevel)
      if (ier.ne.0) call vmerr(ier, maxfn)

      call mvnlik(twrk,typ,npar,x,y,a,aqelik,c,m,w1,w2)
      d2=aelik-aqelik
      lod=0.217142d0*d2
      asyp=chip(d2,1)

      x(2)=abs(x(2))
      x(3)=abs(x(3))
      x(4)=abs(x(4))
      yvar=100.0d0/(x(2)+x(3)+x(4))
      if (plevel.gt.0) then
        write(*,'(2(/a,i5))') 
     2    'Number of sibships         = ', nfam,
     3    'Number of observations     = ', tot  
        write(*,'(a,f12.6,3(/a,f12.6,a,f5.1,a))') 
     2  'Trait mean                 = ', x(1),
     3  'Additive genetic variance  = ', x(2), ' (',x(2)*yvar,'%)',
     3  'QTL genetic variance       = ', x(3), ' (',x(3)*yvar,'%)',
     4  'Environmental variance     = ', x(4), ' (',x(4)*yvar,'%)' 
        write(*,'(a,f8.2,4x,a,f5.2,a/a,i5)') 
     5  'Linkage chi-square (lod)   = ', d2,' (',lod,')',
     6  'Total function evaluations = ', iter 
      else
        call phist(asyp,1.0d0,histo)
        write(*,'(a10,1x,i6,3x,a,4x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))')
     &    locnam, sibs, '-', lod, asyp, 1.0d0, 0, 'VC ',histo
      end if
      return
      end
C end-of-sibqtl 
C
C Variance components analysis 
C
      subroutine varcom(wrk,twrk,locnam,trait,pedigree,actset,num,
     2              nfound,id,fa,mo,sex,locus,numloc,
     3              untyped,a,c,plevel,typ)
      integer IBDSIZ,MAXIBD,NPAR,MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MAXPAR=4,MAXIBD=1000, 
     &           IBDSIZ=MAXIBD*(MAXIBD+1)/2, MISS=-9999)
C
      integer MAXFN
      double precision GRADTL
      parameter (GRADTL = 1.0d-12, MAXFN = 1000)
C
      integer trait,twrk,typ,wrk,plevel
      character*10 locnam
C  Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Array to contain covariances and inverse
      double precision a(IBDSIZ), c(IBDSIZ)
C work arrays
      logical untyped(MAXSIZ)
      double precision x(MAXPAR), w(MAXPAR*(MAXPAR+5))
      double precision m(MAXSIZ),w1(MAXSIZ),w2(MAXSIZ),y(MAXSIZ)
C local variables
      integer i, i1,i2,i3,i4,ier, iter1, iter2, modl, nn, pos, tot
      logical last
      double precision lik, lik_ae, domtest, gentest,
     &                 va, vd, ve, ymean, yvar
C functions
      double precision chip

      last=.false.
      nfam=0
      tot=0 
      lik=0.0d0
      lik_ae=0.0d0
      ymean=0.0d0
      yvar=0.0d0
      rewind(wrk)
    5 continue
        call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &             numloc, last)
        if (last) goto 20
C
        if (actset.le.0) goto 5
C
        nfam=nfam+1
        nobs=0

        do 50 i=1,num
        if (locus(i,trait).ne.MISS) then
          untyped(i)=.false.
          nobs=nobs+1
          tot=tot+1
          y(nobs)=dble(locus(i,trait))
          call moment(tot,y(nobs),ymean,yvar)
        else
          untyped(i)=.true.
        end if
   50   continue

        call kinship(num,nfound,fa,mo,a)
        call frater(num,nfound,fa,mo,a,c)
        if (nobs.ne.num) then
          nn=0
          pos=0
          do 60 i=1, num
            if (.not.untyped(i)) then
              do 65 j=1,i
              if (.not.untyped(j)) then
                nn=nn+1
                a(nn)=a(pos+j)
                c(nn)=c(pos+j)
              end if
   65         continue
            end if
            pos=pos+i
   60     continue
        else
          nn=nobs*(nobs+1)/2
        end if
        if (nobs.gt.0) then
          write(twrk) nobs, nn, (y(i),i=1,nobs),
     &                (a(i),i=1, nn), (c(i),i=1, nn)
        end if
C
      goto 5
   20 continue
      yvar=yvar/dfloat(tot)
C
      write(*,'(/a/a,a10,a/a)') 
     2  '------------------------------------------------',
     3  'Variance components analysis for "',locnam,'"',
     4  '------------------------------------------------' 
      write(*,'(2(/a,i5))') 
     2  'Number of families         = ', nfam,
     3  'Number of observations     = ', tot  
C
C plug in starting values and iterate for MLEs
C ADE
C
      x(1)=ymean
      x(2)=0.1d0*yvar
      if (typ.eq.2) then
        modl=2
        npar=4
        typ=2
        x(3)=0.0d0
        x(4)=0.9d0*yvar

        call initvm(npar, i1,i2,i3,i4, ier)
        call varmet(npar,x,lik,w(i3),w,w(i1),w(i2),w(i4),
     &         gradtl,maxfn,ier,iter1,twrk,modl,y,a,c,m,w1,w2,plevel)
C
        if (ier.ne.0) call vmerr(ier, maxfn)
        
        call mvnlik(twrk,modl,npar,x,y,a,lik,c,m,w1,w2)
        va=abs(x(2))
        vd=abs(x(3))
        ve=abs(x(4))

C starting values for AE run
        x(2)=va+vd
        x(3)=ve
      else
        x(3)=0.9d0*yvar
      end if
C AE
      npar=3
      modl=1

      call initvm(npar, i1,i2,i3,i4, ier)
      call varmet(npar,x,lik_ae,w(i3),w,w(i1),w(i2),w(i4),
     &       gradtl,maxfn,ier,iter2,twrk,modl,y,a,c,m,w1,w2,plevel)
C
      if (ier.ne.0) call vmerr(ier, maxfn)
      domtest=lik_ae-lik
      if (typ.eq.1 .or. domtest .le. 3.84d0) then
        call mvnlik(twrk,modl,npar,x,y,a,lik,c,m,w1,w2)
        va=abs(x(2))
        vd=0.0d0
        ve=abs(x(3))
      else
        npar=4
      end if
C test A(D)E v E
      gentest=dfloat(tot)*(log(yvar)+1.0d0)-lik

      yvar=100.0d0/(va + vd + ve)
      write(*,'(a,f12.6/a,f12.6,a,f5.1,a)') 
     2  'Trait mean                 = ', x(1),
     3  'Additive genetic variance  = ', va  , ' (',va*yvar,'%)' 
      if (npar.eq.4) then
        write(*,'(a,f12.6,a,f5.1,a)') 
     &  'Dominance genetic variance = ', vd  , ' (',vd*yvar,'%)' 
      end if
      write(*,'(a,f12.6,a,f5.1,a/a,f12.6)')
     2  'Environmental variance     = ', ve  , ' (',ve*yvar,'%)',
     3  'Model loglikelihood        = ', -0.5d0*lik 
      if (typ.eq.2) then
        write(*,'(/a,f8.2,4x,a,i1,a,f5.3,a)') 
     2    'Chi-square testing VD=0    = ', domtest,
     3    ' (df=',1,', P=',chip(domtest,1),')' 
      end if
      write(*,'(/a,f8.2,4x,a,i1,a,f5.3,a)') 
     4  'Chi-square testing VG=0    = ', gentest,
     5  ' (df=',npar-2,', P=',chip(gentest,npar-2),')' 
      write(*,'(a,i5)') 
     &  'Total function evaluations = ', max(iter1,iter2) 
      return
      end
C end-of-varcom 
C
C MVN model loglikelihood
C
      subroutine mvnlik(twrk,typ,npar,x,y,a,q,c,m,w1,w2)
C
      integer IBDSIZ, MAXSIZ
      parameter (MAXSIZ=1000, IBDSIZ=MAXSIZ*(MAXSIZ+1)/2)

      integer npar, typ, twrk
      double precision x(*),q
      double precision y(MAXSIZ), a(IBDSIZ)
C work arrays
      double precision c(IBDSIZ),m(MAXSIZ),w1(MAXSIZ),w2(MAXSIZ)
C local variables
      integer i, ifault, n, nn, nullty, pos
      double precision quad, logdet, va, ve, vq, ymean

      ifault=0
      nullty=0
      q=0.0d0
      ymean=x(1)
      va=abs(x(2))
      vq=0.0d0
      ve=abs(x(npar))
      if (typ.eq.2) vq=abs(x(3))
      
      rewind(twrk)
   10 continue
        read(twrk,end=50) n, nn, (y(i),i=1,n), 
     &                    (a(i),i=1, nn), (c(i),i=1, nn)
        pos=0
        do 15 i=1,nn
          a(i)=a(i)*va+c(i)*vq
   15   continue
        do 20 i=1,n
          pos=pos+i
          m(i)=ymean
          a(pos)=a(pos)+ve
   20   continue
        call syminv(a,n,nn,c,w1,logdet,nullty,ifault)

        if (ifault.ne.0) then 
          q=1.0d99
        else
          call quadmult(n,y,m,nn,c,w1,w2,quad)
          q=q+logdet+quad
        end if
      goto 10
   50 continue

      return
      end
C end-of-mvnlik
C
C AS 319 Varmet: likelihood function work arrays passed directly
C                likelihood function explicitly named
C
      subroutine varmet(npar,b,f0,g,h,c,d,t,gradtl,maxfn,ifault,ifn,
     &                  twrk,typ,y,a,ainv,m,w1,w2,plevel)
      integer IBDSIZ, ICMAX, MAXIBD, MAXSIZ
      double precision TOLER, W
      parameter (ICMAX=20, MAXSIZ=1000,MAXIBD=1000, 
     &           IBDSIZ=MAXIBD*(MAXIBD+1)/2,TOLER=0.00001d0, W=0.2d0)
      integer ifn, plevel, twrk, typ
      double precision b(npar),f0, g(npar), h(npar,npar),c(npar),
     &                 d(npar),t(2*npar),gradtl,d1,s,ck,f1,d2
      double precision y(MAXSIZ), a(IBDSIZ)
C work arrays
      double precision ainv(IBDSIZ),m(MAXSIZ),w1(MAXSIZ),w2(MAXSIZ)
C local variables
      integer i, ic, icount, ilast, ig, k, l, np
C
      ig = 0
      ifn = 0
      ifault = 0
      np = npar + 1
C
      call mvnlik(twrk,typ,npar,b,y,a,f0,ainv,m,w1,w2)
      ifn = ifn + 1
      if (plevel.gt.1) then
        write(*,'(i4,5(1x,f12.6):)') ifn,f0,(b(i),i=1, npar)
      end if
C
      call grad(npar,b,f0,g,t(np),gradtl,ifault,
     &          twrk,typ,y,a,ainv,m,w1,w2)
      if (ifault.gt.0) return
C
      ig = ig + 1
      ifn = ifn + npar
      if (ifn.gt.maxfn) then
        ifault = 4
        return
      endif
C
   10 do 30 k = 1,npar
         do 20 l = 1,npar
            h(k,l) = 0.0d0
   20    continue
         h(k,k) = 1.00d0
   30 continue
      ilast = ig
C
   40 do 50 i = 1,npar
         d(i) = b(i)
         c(i) = g(i)
   50 continue
C
      d1 = 0.0d0
      do 70 i = 1,npar
         s = 0.0d0
         do 60 j = 1,npar
            s = s - h(i,j)*g(j)
   60    continue
         t(i) = s
         d1 = d1 - s*g(i)
   70 continue
C
      if(d1.le.0.0d0) then
         if(ilast.eq.ig) then
            return
         endif
         go to 10
      else
         ck = 1.0d0
         ic = 0
   90    icount = 0
         do 100 i = 1,npar
            b(i) = d(i) + ck*t(i)
            if(b(i).eq.d(i)) then
               icount = icount + 1
            endif
  100    continue
C
         if(icount.ge.npar) then
            if(ilast.eq.ig) then
               return
            endif
            go to 10
         else
            call mvnlik(twrk,typ,npar,b,y,a,f1,ainv,m,w1,w2)
            ifn = ifn + 1
            if (plevel.gt.1) then
              write(*,'(i4,5(1x,f12.6):)') ifn,f1,(b(i),i=1, npar)
            end if
            if (ifn.gt.maxfn) then
              ifault = 4
              return
            else if (f1.eq.1.0d99) then
              ck = W * ck
              ic = ic+1
              if (ic.gt.ICMAX) then
                ifault = 3
                return
              endif
              go to 90
C
            else if(f1.ge.f0 - d1*ck*TOLER) then
               ck = W * ck
               go to 90
            else
               f0 = f1
               call grad(npar,b,f0,g,t(np),gradtl,ifault,
     &                   twrk,typ,y,a,ainv,m,w1,w2)
               if(ifault.gt.0) then
                  return
               endif
               ig = ig + 1
               ifn = ifn + npar
               if(ifn.gt.maxfn) then
                  ifault = 4
                  return
               endif
C
               d1 = 0.0d0
               do 130 i = 1,npar
                  t(i) = ck*t(i)
                  c(i) = g(i) - c(i)
                  d1 = d1 + t(i)*c(i)
  130          continue
C
               if(d1.le.0.0d0) then
                  goto 10
               endif
C
               d2 = 0.0d0
               do 150 i = 1,npar
                  s = 0.0d0
                  do 140 j = 1,npar
                     s = s + h(i,j)*c(j)
  140             continue
                  d(i) = s
                  d2 = d2 + s*c(i)
  150          continue
               d2 = 1.0d0 + d2/d1
C
               do 170 i = 1,npar
                  do 170 j = 1,npar
                     h(i,j) = h(i,j) - (t(i)*d(j) + d(i)*t(j) -
     &               d2*t(i)*t(j))/d1
  170          continue
            endif
         endif
      endif
      go to 40
      end
C end-of-varmet
C
C Approximate gradient
C
      subroutine grad(npar,b,f0,g,sa,er,ifault,
     &                twrk,typ,y,a,c,m,w1,w2)
      integer IBDSIZ, MAXIBD, MAXSIZ
      parameter (MAXSIZ=1000,MAXIBD=1000, 
     &           IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer ifault, twrk, typ
      double precision b(npar),er,f0,g(npar),h,sa(npar)
      double precision y(MAXSIZ), a(IBDSIZ)
C work arrays
      double precision c(IBDSIZ),m(MAXSIZ),w1(MAXSIZ),w2(MAXSIZ)
C local variables 
      integer i, jc, jcmax
      double precision f1
C
      jcmax=npar-2
      jc = 0
C
      do 20 i = 1,npar
        h =(dabs(b(i)) +dsqrt(er)) *dsqrt(er)
        sa(i) = b(i)
        b(i) = b(i) + h
        call mvnlik(twrk,typ,npar,b,y,a,f1,c,m,w1,w2)
        b(i) = sa(i)
C
        if (f1.eq.1.0d99) then
          f1 = f0 + h
          jc = jc + 1
        endif
C
        g(i) = (f1 -f0)/h
   20 continue
C
      if (jc.gt.jcmax) ifault = 2
      return
      end
C end-of-grad
C 
C Initialize varmet work arrays etc
C
      subroutine initvm(npar, i1,i2,i3,i4, ier)
      integer i1,i2,i3,i4,ier,npar
      ier=0
      i1 = npar*npar + 1
      i2 = i1 + npar
      i3 = i2 + npar
      i4 = i3 + npar
      return
      end
C end-of-initvar
C
C varmet error messages
C
      subroutine vmerr(ier, maxfn)
      integer ier, maxfn
      if (ier.eq.1) then
        write(*,'(/a/)') 'ERROR: Likelihood undefined at initial value.'
      else if (ier.eq.2) then
        write(*,'(/a/)') 'ERROR: Gradient undefined in too many dims.'
      else if (ier.eq.3) then
        write(*,'(/a/)') 'ERROR: Unable to find minimum.'
      else if (ier.eq.4) then
        write(*,'(/a,i4,a/)') 'ERROR: Exceeded ',maxfn,' evaluations.'
      end if
      return
      end
C end-of-vmerr
