solve1

 Copyright (C) 2001 Michel Juillard

0001 % Copyright (C) 2001 Michel Juillard
0002 %
0003 function [x,check] = solve1(func,x,j1,j2,jacobian_flag,varargin)
0004 
0005   global M_ options_ fjac  
0006 
0007   nn = length(j1);
0008   fjac = zeros(nn,nn) ;
0009   g = zeros(nn,1) ;
0010 
0011   tolf = eps^(2/3) ;
0012   tolmin = 3.7e-11 ;
0013   tolx = 3.7e-11 ;
0014 
0015   stpmx = 100 ;
0016   maxit = 2000 ;
0017 
0018   check = 0 ;
0019 
0020   fvec = feval(func,x,varargin{:});
0021   fvec = fvec(j1);
0022   
0023   i = find(~isfinite(fvec));
0024   
0025   if ~isempty(i)
0026     disp(['STEADY:  numerical initial values incompatible with the following' ...
0027       ' equations'])
0028     disp(j1(i)')
0029   end
0030   
0031   f = 0.5*fvec'*fvec ;
0032 
0033   if max(abs(fvec)) < 0.01*tolf
0034     return ;
0035   end
0036 
0037   stpmax = stpmx*max([sqrt(x'*x);nn]) ;
0038   first_time = 1;
0039   for its = 1:maxit
0040     if jacobian_flag
0041       [fvec,fjac] = feval(func,x,varargin{:});
0042     else
0043       fvec = feval(func,x,varargin{:});
0044       dh = max(abs(x(j2)),options_.gstep*ones(nn,1))*eps^(1/3);
0045       
0046       for j = 1:nn
0047     xdh = x ;
0048     xdh(j2(j)) = xdh(j2(j))+dh(j) ;
0049     t = feval(func,xdh,varargin{:});
0050     fjac(:,j) = (t(j1) - fvec)./dh(j) ;
0051     g(j) = fvec'*fjac(:,j) ;
0052       end
0053     end
0054     fvec = fvec(j1);
0055     fjac = fjac(j1,j2);
0056     g = (fvec'*fjac)';
0057     if options_.debug
0058       disp(['cond(fjac) ' num2str(cond(fjac))])
0059     end
0060     M_.unit_root = 0;
0061     if M_.unit_root
0062       if first_time
0063         first_time = 0;
0064     [q,r,e]=qr(fjac);
0065     n = sum(abs(diag(r)) < 1e-12);
0066     fvec = q'*fvec;
0067     p = e*[-r(1:end-n,1:end-n)\fvec(1:end-n);zeros(n,1)];
0068     disp(' ')
0069     disp('STEADY with unit roots:')
0070     disp(' ')
0071     if n > 0
0072       disp(['   The following variable(s) kept their value given in INITVAL' ...
0073         ' or ENDVAL'])
0074       disp(char(e(:,end-n+1:end)'*M_.endo_names))
0075     else
0076       disp('   STEADY can''t find any unit root!')
0077     end
0078       else
0079     [q,r]=qr(fjac*e);
0080     fvec = q'*fvec;
0081     p = e*[-r(1:end-n,1:end-n)\fvec(1:end-n);zeros(n,1)];
0082       end    
0083 %    elseif cond(fjac) > 10*sqrt(eps)
0084     elseif cond(fjac) > 1/sqrt(eps)
0085     fjac2=fjac'*fjac;
0086     p=-(fjac2+sqrt(nn*eps)*max(sum(abs(fjac2)))*eye(nn))\(fjac'*fvec);
0087     else
0088       p = -fjac\fvec ;
0089     end
0090     xold = x ;
0091     fold = f ;
0092 
0093     [x,f,fvec,check]=lnsrch1(xold,fold,g,p,stpmax,func,j1,j2,varargin{:});
0094 
0095     if options_.debug
0096       disp([its f])
0097       disp([xold x])
0098     end
0099       
0100     if check > 0
0101       den = max([f;0.5*nn]) ;
0102       if max(abs(g).*max([abs(x');ones(1,nn)])')/den < tolmin
0103     return
0104       else
0105     disp (' ')
0106     disp (['SOLVE: Iteration ' num2str(its)])
0107     disp (['Spurious convergence.'])
0108     disp (x)
0109     return
0110       end
0111 
0112       if max(abs(x-xold)./max([abs(x);ones(1,nn)])') < tolx
0113     disp (' ')
0114     disp (['SOLVE: Iteration ' num2str(its)])
0115     disp (['Convergence on dX.'])
0116     disp (x)
0117     return
0118       end
0119     elseif f < tolf
0120       return
0121     end
0122   end
0123   
0124   check = 1;
0125   disp(' ')
0126   disp('SOLVE: maxit has been reached')
0127 
0128 % 01/14/01 MJ lnsearch is now a separate function
0129 % 01/16/01 MJ added varargin to function evaluation
0130 % 04/13/01 MJ added test  f < tolf !!
0131 % 05/11/01 MJ changed tests for 'check' so as to remove 'continue' which is
0132 %             an instruction which appears only in version 6
0133 
0134 
0135 
0136 
0137 
0138 
0139 
0140 
0141 
0142