1,2c1,12
< # This is a primal-dual log barrier form of the
< # interior point LP solver of Lustig, Marsten and Shanno ORSA J Opt 1992.
---
> subroutine rqfnb(n,p,a,y,rhs,d,u,beta,eps,wn,wp,nit,info)
> integer n,p,info,nit(3)
> double precision a(p,n),y(n),rhs(p),d(n),u(n),wn(n,9),wp(p,p+3)
> double precision one,beta,eps
> parameter( one = 1.0d0)
> call lpfnb(n,p,a,y,rhs,d,u,beta,eps,wn(1,1),wn(1,2),
>         wp(1,1),wn(1,3),wn(1,4),wn(1,5),wn(1,6),
>         wp(1,2),wn(1,7),wn(1,8),wn(1,9),wp(1,3),wp(1,4),nit,info)
> return
> end
> # This is a revised form of my primal-dual log barrier form of the
> # interior point LP solver based on Lustig, Marsten and Shanno ORSA J Opt 1992.
6,7d15
< # The primary difference between this code and the previous version fna.r is
< # that we assume a feasible starting point so p,d,b feasibility gaps = 0.
11,25c19
< # The linear system we are trying to solve at each interation is:
< # 		 Adx = 0
< # 	     dx + ds = 0
< # 	A'dy -dw +dz = 0
< # 	   Xdz + Zdx = me - XZe - DXDZe
< # 	   Sdw + Wds = me - SWe - DSDWe 
< # But the algorithm proceeds in two steps the first of which is to solve:
< # 		 Adx = 0
< # 	     dx + ds = 0
< # 	A'dy -dw +dz = 0
< # 	   Xdz + Zdx =  - XZe 
< # 	   Sdw + Wds =  - SWe
< # and then to make some refinement of mu and modify the implied Newton step.
< # Denote dx,dy,dw,ds,dz as the steps for the respective variables x,y,w,s,z, and
< # the corresponding upper case letters are the diagonal matrices respectively.
---
> # Denote dx,dy,dw,ds,dz as the steps for the respective variables x,y,w,s,z
27,55c21,22
< # To illustrate the use of the function we include a calling routine to
< # compute solutions to the linear quantile regression estimation problem.
< # See the associated S function rqfn for details on the calling sequence.
< # On input:
< # 	a is the p by n matrix X'
< # 	y is the n-vector of responses
< # 	u is the n-vector of upper bounds 
< #       d is an n-vector of ones
< #       wn is an n-vector of ones in the first n elements
< # 	beta is a scaling constant, conventionally .99995
< # 	eps is a convergence tolerance, conventionally 1d-07
< # On output:
< # 	a,y are unaltered
< # 	wp contains the solution  coefficient vector in the first p elements
< # 	wn contains the residual vector in the first n elements
< # 
< # 
< subroutine rqfn(n,p,a,y,rhs,d,u,beta,eps,wn,wp,aa,nit,info)
< integer n,p,info,nit(3)
< double precision a(p,n),y(n),rhs(p),d(n),u(n),wn(n,10),wp(p,p+3),aa(p,p)
< double precision one,beta,eps
< parameter( one = 1.0d0)
< call fna(n,p,a,y,rhs,d,u,beta,eps,wn(1,1),wn(1,2),
< 	wp(1,1),wn(1,3),wn(1,4),wn(1,5), wn(1,6),
< 	wp(1,2),wn(1,7),wn(1,8),wn(1,9),wn(1,10),wp(1,3), wp(1,4),aa,nit,info)
< return
< end
< subroutine fna(n,p,a,c,b,d,u,beta,eps,x,s,y,z,w,
< 		dx,ds,dy,dz,dw,dsdw,dxdz,rhs,ada,aa,nit,info)
---
> subroutine lpfnb(n,p,a,c,b,d,u,beta,eps,x,s,y,z,w,
> 	dx,ds,dy,dz,dw,dr,rhs,ada,nit,info)
57c24
< integer n,p,pp,i,info,nit(3)
---
> integer n,p,pp,i,info,nit(3),maxit
59,60c26,27
< double precision zero,one,mone,big,ddot,dmax1,dmin1,dasum
< double precision deltap,deltad,beta,eps,cx,by,uw,uz,mu,mua,acomp,rdg,g
---
> double precision zero,one,mone,big,ddot,dmax1,dmin1,dxdz,dsdw
> double precision deltap,deltad,beta,eps,mu,gap,g
62c29
< double precision aa(p,p),dx(n),ds(n),dy(p),dz(n),dw(n),dxdz(n),dsdw(n)
---
> double precision dx(n),ds(n),dy(p),dz(n),dw(n),dr(n)
65d31
< parameter( half  = 0.5d0)
67c33
< parameter( mone   = -1.0d0)
---
> parameter( mone  = -1.0d0)
68a35
> parameter( maxit  = 50)
70c37
< # Initialization:  We try to follow the notation of LMS
---
> # Initialization:  We follow the notation of LMS
89c56
< # Start at the OLS estimate for the parameters
---
> # Start at the OLS estimate for the dual vector y
91c58,60
< call stepy(n,p,a,d,y,aa,info)
---
> do i=1,n
> 	d(i)=one
> call stepy(n,p,a,d,y,ada,info)
93,100d61
< # Save sqrt of aa' for future use for confidence band
< do i=1,p{
< 	do j=1,p
< 		ada(i,j)=zero
<         ada(i,i)=one
< 	}
< call dtrtrs('U','T','N',p,p,aa,p,ada,p,info)
< call dcopy(pp,ada,1,aa,1)
105d65
< # N.B. x must be initialized on input: for rq as (one-tau) in call coordinates
107,110c67,69
< 	d(i)=one
< 	if(dabs(s(i)) < eps){
< 		z(i) = dmax1( s(i),zero) + eps
< 		w(i) = dmax1(-s(i),zero) + eps
---
> 	if(dabs(s(i))<eps){
> 		z(i)=dmax1(s(i), zero) + eps
> 		w(i)=dmax1(-s(i),zero) + eps
113,114c72,73
< 		z(i) = dmax1( s(i),zero)
< 		w(i) = dmax1(-s(i),zero) 
---
> 		z(i)=dmax1(s(i), zero) 
> 		w(i)=dmax1(-s(i),zero)
118,125c77,78
< cx = ddot(n,c,1,x,1)
< by = ddot(p,b,1,y,1)
< uw = dasum(n,w,1)
< uz = dasum(n,z,1)
< # rdg =  (cx - by + uw)/(one + dabs( by - uw))
< # rdg =  (cx - by + uw)/(one + uz + uw)
< rdg =  (cx - by + uw)
< while(rdg > eps) {
---
> gap = ddot(n,z,1,x,1)+ddot(n,w,1,s,1)
> while(gap > eps && nit(1)<maxit) {
127c80
< 	do i =1,n{
---
> 	do i = 1,n{
130c83
< 		dx(i)=d(i)*ds(i)
---
> 		dz(i)=d(i)*ds(i)
132c85,87
< 	call dgemv('N',p,n,one,a,p,dx,1,zero,dy,1)#rhs
---
> 	call dcopy(p,b,1,dy,1)#save rhs
> 	call dgemv('N',p,n,mone,a,p,x,1,one,dy,1) 
> 	call dgemv('N',p,n,one,a,p,dz,1,one,dy,1) 
136c91
< 	call dgemv('T',p,n,one,a,p,dy,1,mone,ds,1)
---
> 	call dgemv('T',p,n,one,a,p,dy,1,mone,ds,1) #ds -> A'dy - ds
143,145c98
< 		dw(i)=w(i)*(dx(i)/s(i) - one)
< 		dxdz(i)=dx(i)*dz(i)
< 		dsdw(i)=ds(i)*dw(i)
---
> 		dw(i)=-w(i)*(ds(i)/s(i) + one)
153c106
< 	if(deltap*deltad<one){
---
> 	if(min(deltap,deltad) < one){
155,157c108,111
< 		acomp=ddot(n,x,1,z,1)+ddot(n,s,1,w,1)
< 		g=acomp+deltap*ddot(n,dx,1,z,1)+
< 			deltad*ddot(n,dz,1,x,1)+ 
---
> 		# Update mu
> 		mu = ddot(n,x,1,z,1)+ddot(n,s,1,w,1)
> 		g = mu + deltap*ddot(n,dx,1,z,1)+
> 			deltad*ddot(n,dz,1,x,1) +
160c114
< 			deltad*ddot(n,dw,1,s,1)+ 
---
> 			deltad*ddot(n,dw,1,s,1) +
162,166c116,117
< 		mu=acomp/dfloat(2*n)
< 		mua=g/dfloat(2*n)
< 		mu=mu*(mua/mu)**3
< 		#if(acomp>1) mu=(g/dfloat(n))*(g/acomp)**2
< 		#else mu=acomp/(dfloat(n)**2)
---
> 		mu = mu * ((g/mu)**3) /dfloat(2*n)
> 		# Compute modified step
168c119
< 			dz(i)=d(i)*(mu*(1/s(i)-1/x(i))+
---
> 			dr(i)=d(i)*(mu*(1/s(i)-1/x(i))+
172,175c123,125
< 		call dgemv('N',p,n,one,a,p,dz,1,one,dy,1)#new rhs
< 		call dpotrs('U',p,1,ada,p,dy,p,info)
< 		call daxpy(p,mone,dy,1,rhs,1)#rhs=ddy
< 		call dgemv('T',p,n,one,a,p,rhs,1,zero,dw,1)#dw=A'ddy
---
> 		call dgemv('N',p,n,one,a,p,dr,1,one,dy,1)# new rhs
> 		call dpotrs('U',p,1,ada,p,dy,p,info)# backsolve for dy
> 		call dgemv('T',p,n,one,a,p,dy,1,zero,u,1)#ds=A'ddy
179,182c129,134
< 			dx(i)=dx(i)-dz(i)-d(i)*dw(i)
< 			ds(i)=-dx(i)
< 			dz(i)=mu/x(i) - z(i)*dx(i)/x(i) - z(i) - dxdz(i)/x(i)
< 			dw(i)=mu/s(i) - w(i)*ds(i)/s(i) - w(i) - dsdw(i)/s(i)
---
> 			dxdz =  dx(i)*dz(i)
> 			dsdw =  ds(i)*dw(i)
> 			dx(i)=  d(i)*(u(i)-z(i)+w(i))-dr(i)
> 			ds(i)= -dx(i)
> 			dz(i)= -z(i)+(mu - z(i)*dx(i) - dxdz)/x(i)
> 			dw(i)= -w(i)+(mu - w(i)*ds(i) - dsdw)/s(i)
184c136
< 			else deltap=dmin1(deltap,-s(i)/ds(i))
---
> 			if(ds(i)<0)deltap=dmin1(deltap,-s(i)/ds(i))
196,202c148
< 	cx=ddot(n,c,1,x,1)
< 	by=ddot(p,b,1,y,1)
< 	uw = dasum(n,w,1)
< 	uz = dasum(n,z,1)
< 	#rdg=(cx-by+uw)/(one+dabs(by-uw))
< 	#rdg=(cx-by+uw)/(one+uz+uw)
< 	rdg=(cx-by+uw)
---
> 	gap = ddot(n,z,1,x,1)+ddot(n,w,1,s,1)
208a155,170
> subroutine stepy(n,p,a,d,b,ada,info)
> integer n,p,pp,i,info
> double precision a(p,n),b(p),d(n),ada(p,p),zero
> parameter( zero = 0.0d0)
> # Solve the linear system ada'x=b by Choleski -- d is diagonal
> # Note that a isn't altered, and on output ada returns the upper
> # triangle Choleski factor, which can be reused, eg with blas dtrtrs
> pp=p*p
> do j=1,p
> 	do k=1,p
> 		ada(j,k)=zero
> do i=1,n
> 	call dsyr('U',p,d(i),a(1,i),1,ada,p)
> call dposv('U',p,1,ada,p,b,p,info)
> return
> end
