swh:1:snp:3aec91c51d538d62f3f51f6a0af59fe452f330ab
Raw File
Tip revision: b69d41b31f2c5b400795b96a622faa6478947c12 authored by Zhu Wang on 22 September 2014, 21:27:03 UTC
version 0.1-14
Tip revision: b69d41b
outloop.f
C outer loop: decrement lambda
C input:
C mu: a vector
C output
C b: beta
C bz: b0
C resdev: residual deviance
C ypre: yhat

      subroutine outloop(x,y,weights, wt, n,m, penalty, nlambda, lam, 
     +alpha, 
     +gam, theta,rescale, mu,eta, family, standardize, nulldev, 
     +thresh, maxit, 
     +innermaxit, eps, trace, start, startv,b, bz,resdev,ypre, convout,
     + satu, good, ep, outpll)

      implicit none
      integer n,m,i,j,k,penalty, nlambda, family, standardize, maxit,
     +innermaxit, trace,convmid,convout(nlambda), startv, rescale, 
     +satu, good
      double precision x(n,m), y(n), wt(n), lam(m, nlambda),alpha,
     +gam, theta,mu(n),eta(n), nulldev,thresh, eps, b(m,nlambda),
     +bz(nlambda),xold(n,m), yold(n), start(m+1), pendev(maxit),
     +resdev(nlambda), v(n), ypre(n,nlambda), lamk(m), beta(m), b0,dev,
     +weights(n),yhat(n),ep, pll(maxit), outpll(maxit, nlambda),
     +normx(m),xd(m),avg 

      if(family .NE. 1)then
      call preprocess(x, y, n, m, weights, family, standardize,
     +normx, xd, avg)
      endif
C keep a copy of x and y in case x and y will be changed in subroutine lmnet if standardize = 1
      do 100 j=1, m
      do 110 i=1, n
      xold(i,j)=x(i,j)
 110     continue
 100     continue
      call DCOPY(n, y, 1, yold, 1)
      if(startv .EQ. 0)then
      b0 = eta(1)
      do j=1, m
      beta(j) = 0
      enddo
      else 
       b0 = start(1)
       do j=1, m
       beta(j) = start(j+1)
       enddo
      endif

      k = 1
      satu = 0

 1000 if(k .LE. nlambda .AND. satu .EQ. 0)then
      if(trace.EQ.1)then
      call dblepr("", -1, 1,0)
      call dblepr("Outer loop: Decrement lambda", -1, 1,0)
      call intpr("  lambda iteration", -1, k, 1)
      call dblepr("  lambda value", -1, lam(1,k), 1)
      endif
      do 10 j=1,m
      lamk(j) = lam(j,k)
  10  continue
      call midloop(n, m, x, y, xold, yold, weights, mu, eta, family, 
     +penalty, lamk,
     + alpha, gam,theta, rescale, standardize, eps, innermaxit,
     + maxit, thresh, nulldev, wt, beta, b0, yhat, dev, trace,convmid,
     +satu, ep, pll,normx,xd,avg)
C      if(family.EQ.2 .AND. satu.EQ.1)then
C      call intpr("  satu indicator", -1, satu, 1)
C      endif
      if(satu .EQ. 1)then
      good = k - 1
      endif
      convout(k)=convmid
      do 15 i=1, maxit
      outpll(i,k) = pll(i)
  15  continue
      
      do 20 j=1, m
      b(j, k) = beta(j)
  20  continue
      bz(k) = b0
      resdev(k) = dev
      call linkinv(n, yhat, family, v)
      do 30 i=1, n
      ypre(i,k) = v(i)
  30  continue
      k = k + 1
      if(k .LE. nlambda .AND. satu .EQ. 0)then
       do 40 j=1,m
       b(j, k) = b(j, k-1)
  40   continue
      endif
      goto 1000
      endif
   
      return
      end  

back to top