dynare/scilab/dr1.sci

function [dr]=dr1(iorder,dr,correct)
// Copyright (C) 2001 Michel Juillard
// 
 
xlen = xkmax_+xkmin_+1;
klen = ykmin_+ykmax_+1;
iyv = iy_';
iyv = iyv(:);
iyr0 = find(iyv)';
it_ = ykmin_+1;
 
 
if exo_nbr==0 then
  exe_ = [];
end
 
if ~(iy_(ykmin_+1,:)>0) then
  error('Error in model specification: some variables don""t appear as current');
end
 
if ykmax_==0 then
  error('No forward variable: no point in using dr1');
end
 
if xlen>1 then
  error('SS: stochastic exogenous variables must appear only at the'+' current period. Use additional endogenous variables');
end
 
tempex = ex_;
 
it_ = ykmin_+1;
 
z = dr('ys')*ones(1,klen);
z = z(iyr0);
 
jacobia_ = real(jacob_a('ff1_',[z;exe_]));
 
ex_ = tempex;
tempex = [];
 
nz = size(z,1);
pred_var = find(or(iy_(1:ykmin_,:),1));
 
fwrd_var = find(or(iy_(ykmin_+2:ykmin_+ykmax_+1,:),1));
both_var = intersect(pred_var,fwrd_var);
if size(both_var,'*')
  pred_var = setdiff(pred_var,both_var);
  fwrd_var = setdiff(fwrd_var,both_var);
end
nboth = length(both_var);
npred = length(pred_var);
nfwrd = length(fwrd_var);
stat_var = setdiff(1:endo_nbr,union(union(pred_var,both_var),fwrd_var));
nstatic = length(stat_var);
order_var = [stat_var,pred_var,both_var,fwrd_var];
k1 = iy_(find((1:klen)~=(ykmin_+1)),:);
b = jacobia_(:,iy_(ykmin_+1,order_var));
a = b\jacobia_(:,nonzeros(k1'));
if exo_nbr then
  fu = b\jacobia_(:,nz+1:size(jacobia_,2));
end
 
// building kmask for z state vector in t+1
if ykmin_>0 then
  if ykmax_>0 then
    %v2 = iy_(ykmin_+2:size(iy_,1),order_var)
    kmask = cumsum(%v2($:-1:1,:),1);
    %v2 = cumsum(iy_(1:ykmin_,order_var),1)
    kmask = [kmask;%v2($:-1:1,:)];
  end
else
  %v1 = iy_(ykmin_+1:klen,order_var)
  kmask = cumsum(%v1($:-1:1,:),1);
end
 
kmask = kmask';
kmask = kmask(:);
i_kmask = find(kmask)';
// index of nonzero entries in kmask
nd = size(i_kmask,1);
// size of the state vector
%v = 1:nd
kmask(i_kmask,1) = %v(:);
 
// auxiliary equations
// elements that are both in z(t+1) and z(t)
k1 = find(kmask(1:length(kmask)-endo_nbr)&kmask(endo_nbr+1:length(kmask)))';
kad = [];
kae = [];
if ~(k1==[]) then
  kad = kmask(k1+endo_nbr);
  kae = kmask(k1);
end
 
// composition of state vector
// col 1: variable;           col 2: lead/lag in z(t+1); 
// col 3: A cols for t+1 (D); col 4: A cols for t (E)
 
kstate = [ones(klen-1,1).*.[1:endo_nbr]' ((klen:-1:2)').*.ones(endo_nbr,1) zeros((klen-1)*endo_nbr,2)];
%v = iy_(:,order_var)
kiy = %v($:-1:1,:)';
kiy = kiy(:);
kstate(1:ykmax_*endo_nbr,3) = kiy(1:ykmax_*endo_nbr)-endo_nbr;
kstate(ykmax_*endo_nbr+1:size(kstate,1),4) = kiy((ykmax_+1)*endo_nbr+1:length(kiy));
// put in E only the current variables that are not already in D
kstate = kstate(i_kmask,:);
dr('kstate') = kstate;

sdyn = endo_nbr-nstatic;
 
// buildind D and E
d = zeros(nd,nd);
e = d;
 
k = find((kstate(:,2)>=(ykmin_+2)) & kstate(:,3))';
d(1:sdyn,k) = a(nstatic+1:size(a,1),kstate(k,3));
k1 = find(kstate(:,2)==(ykmin_+2))';
 
a1 = eye(sdyn,sdyn);
e(1:sdyn,1:size(k1,1)) = -a1(:,kstate(k1,1)-nstatic);
k = find((kstate(:,2)<=(ykmin_+1))&kstate(:,4))';
e(1:sdyn,k) = -a(nstatic+1:size(a,1),kstate(k,4));
k2 = find(kstate(:,2)==(ykmin_+1))';
[k3,k4] = setdiff(kstate(k2,1),kstate(k1,1));

if size(k3,'*') > 0 then
  d(1:sdyn,k2(k4)) = a1(:,k3-nstatic);
end

if ~(kad==[]) then
  for j = 1:size(kad,1)
    d(sdyn+j,kad(j)) = 1;
    e(sdyn+j,kae(j)) = 1;
  end
end

if grep(getversion(),'2.6') then
  [ss,tt,w,sdim] = gschur(e,d,'d');
else
  [ss,tt,w,sdim] = schur(e,d,'d');
end  

nba = nd-sdim;
nyf = sum(kstate(:,2)>(ykmin_+1));
if nba~=nyf then
  dyn_disp('LSS warning: Blanchard-Kahn conditions are not satisfied. Run CHECK to learn more!');
  halt();
   
end
 
np = nd-nyf;
n2 = np+1;
n3 = nyf;
n4 = n3+1;
// derivatives with respect to dynamic state variables
// forward variables
gx = -w(1:n3,n2:nd)'\w(n4:nd,n2:nd)';
// predetermined variables
hx = w(1:n3,1:np)'*gx+w(n4:nd,1:np)';
hx = tt(1:np,1:np)*hx\(ss(1:np,1:np)*hx);
 
 
k1 = find(kstate(n4:nd,2) == ykmin_+1);
k2 = find(kstate(1:n3,2) == ykmin_+2);
dr('ghx') = [hx(k1,:);gx(k2(nboth+1:$),:)]
 
// lead variables actually present in the model
j3 = nonzeros(kstate(:,3));
j4  = find(kstate(:,3));
// derivatives with respect to exogenous variables
if exo_nbr then
  a1 = eye(endo_nbr,endo_nbr);
  aa1 = [];
  if nstatic>0 then
    aa1 = a1(:,1:nstatic);
  end
  dr('ghu') = -[aa1,a(:,j3)*gx(j4,1:npred+nboth)+a1(:,nstatic+1:nstatic+npred+nboth),a1(:,nstatic+npred+nboth+1:$)]\fu
end
 
// static variables
if nstatic>0 then
    temp = -a(1:nstatic,j3)*gx(j4,:)*hx;
    j5 = find(kstate(n4:nd,4));
    temp(:,j5) = temp(:,j5)-a(1:nstatic,nonzeros(kstate(:,4)));
    dr.ghx = [temp; dr.ghx];
    temp = [];
end
 
dr('order_var') = order_var
dr('nstatic') = nstatic
dr('npred') = npred+nboth
 
if iorder==1 then
  return
end
 
// Second order
tempex = ex_;
 
hessian = real(jacob2('ff1_',[z;exe_]));

ex_ = tempex;
clear('tempex');
 
 
np1 = sum(sum(iy_(1:ykmin_,:)>0,2));
zx = [eye(npred+nboth,npred+nboth);dr('ghx');gx*hx;zeros(exo_nbr,np)];
 k1 = nonzeros(iy_(:,order_var)');
if exo_nbr then
  k1 = [k1;(length(k1)+1:length(k1)+exo_nbr)'];
end
kk = matrix(1:length(k1)^2,length(k1),length(k1));
// reorder hessian
kk = kk(k1,k1);
hessian = hessian(:,kk);
rhs = -hessian*(zx.*.zx);
rhs = rhs(:);
 
//lhs
hxt = hx';
gx = dr('ghx');
gx = gx(size(gx,1)-nyf+1:size(gx,1),:); 
Inp = speye(np*np,np*np);
 
f1 = sparse(jacobia_(:,nonzeros(iy_(ykmin_+2,:))));
// f_y'g_xx hx kron hx + f_y g_xx + f_y'g_x h_xx + f_x' h_xx
// 
j1 = sparse(jacobia_(:,iy_(ykmin_+1,order_var)));
lhs = Inp.*.j1;
k = matrix(1:endo_nbr*np*np,endo_nbr,np*np);
nr = size(k,1);
lhs(:,k(nr-nyf+1:nr,:)) = lhs(:,k(nr-nyf+1:nr,:))+hxt.*.hxt.*.f1;
lhs(:,k(nstatic+1:nstatic+np,:)) = lhs(:,k(nstatic+1:nstatic+np,:))+Inp.*.(f1*gx);
dr('ghxx') = lhs\rhs
dr('ghxx') = matrix(dr('ghxx'),endo_nbr,np*np)
 
//ghxu
//rhs
hu = dr('ghu')(nstatic+1:nstatic+np,:);
zu = [zeros(np1,exo_nbr);dr('ghu');gx*hu;eye(exo_nbr,exo_nbr)];
nr = size(dr('ghxx'),1);
rhs = -hessian*(zx.*.zu)-f1*dr('ghxx')(nr-nyf+1:nr,:)*(hx.*.hu);
 
//lhs
lhs = j1;
lhs(:,nstatic+1:nstatic+np) = lhs(:,nstatic+1:nstatic+np)+f1*gx;
dr('ghxu') = lhs\rhs
 
//ghuu
//rhs
rhs = -hessian*(zu.*.zu)-f1*dr('ghxx')(nr-nyf+1:nr,:)*(hu.*.hu);
 
//lhs
dr('ghuu') = lhs\rhs
 
 
// dr.ghs2
// derivatives of F with respect to forward variables
k1 = matrix(1:size(hessian,2),size(jacobia_,2),size(jacobia_,2));
k1 = k1(npred+nboth+endo_nbr+1:npred+endo_nbr+2*nboth+nfwrd,npred+nboth+endo_nbr+1:npred+endo_nbr+2*nboth+nfwrd);
 
nr = size(dr('ghuu'),1);
guu = dr('ghuu')(nr-nyf+1:nr,:);
nr = size(dr('ghu'),1);
gu = dr('ghu')(nr-nyf+1:nr,:);
rhs = -(f1*guu+hessian(:,k1)*(gu.*.gu))*Sigma_e_(:);
lhs = j1;
lhs(:,nstatic+1:nstatic+np) = lhs(:,nstatic+1:nstatic+np)+f1*gx;
nc = size(lhs,2);
lhs(:,nc-nyf+1:nc) = lhs(:,nc-nyf+1:nc)+f1;
dr('ghs2') = lhs\rhs;
 
// 01/08/2001 MJ put return on iorder == 1 after defining dr.kstate and dr.kdyn
// 01/17/2001 MJ added dr.delta_s: correction factor for order = 2
// 01/21/2001 FC correction of delta_s for more than 1 shock
// 01/23/2001 MJ suppression of redundant sum() in delta_s formula
// 02/22/2001 MJ stderr_ replaced by Sigma_e_
// 08/24/2001 MJ changed the order of the variables, separates static
//               variables and handles only one instance of variables both
//               in lead and lag
// 08/24/2001 MJ added sigma to state variables as in Schmitt-Grohe and
//               Uribe (2001)
// 10/30/2002 MJ corrected bugs with lags on several periods